AGSS1 ; IHS/ASDS/EFG - SSN VERIFICATION FROM NPIRS/SSA ;
;;7.1;PATIENT REGISTRATION;**2**;JAN 31, 2007
;
S ;START
D CVARS D LVARS D:$G(AGSDFN) SM1
Q
CVARS ;>SET C VARS modified next line to handle new file format
CVAR S AGSUFAC=$P(AGSCREC,U)
;parse out HRN,SSN,Last Name,First Name,Middle Name,DOB
;modified next 6 lines to handle new file format
S AGSHRN=+$P(AGSCREC,U,2)
S AGSCSSN1=$P(AGSCREC,U,3)
S AGSCLN=$P(AGSCREC,U,4)
S AGSCFN=$P(AGSCREC,U,5)
S AGSCMN=$P(AGSCREC,U,6)
S AGSCDOB=$P(AGSCREC,U,7)
S:AGSCLN[" " AGSCLN=$P(AGSCLN," ") ;NPIRS puts SR JR III as part of the last name
S AGSCSX=$P(AGSCREC,U,8),AGSCVC=$P(AGSCREC,U,9)
S AGSCSSN2=$P(AGSCREC,U,10)
S AGSCFI=$E(AGSCFN),AGSCMI=$E(AGSCMN),AGSCLI=$E(AGSCLN)
F AGSX="AGSCLN","AGSCFN","AGSCMN" S AGSY=$L(@AGSX) I AGSY F AGSI=AGSY:-1:0 Q:$E(@AGSX,AGSI)]" " S @AGSX=$E(@AGSX,0,AGSI-1)
S AGSCNM=AGSCLN_","_AGSCFN
S:AGSCVC="V" AGSCSSN2=AGSCSSN1
ECVAR Q
;D DSPCVAR ; test loop to read records
;
LVARS ;>SET LOCAL VARS
S DFN=0,AGSDFN=0 I '$D(^AUPNPAT("D",AGSHRN)) D DELHRN Q ;no hrn in data base
Q:$G(AGSCVC)'="V" ;only process Vs
I +AGSHRN=999999 D RP Q
LVAR S (DFN,AGSFLG,AGDFNC)=0,AGSLVC="" F S DFN=$O(^AUPNPAT("D",AGSHRN,DFN)) Q:DFN'>0 I $D(^AUPNPAT("D",AGSHRN,DFN,AGSSITE)) S AGDFNC=AGDFNC+1,AGSDFN=DFN
I AGDFNC=1 K AGDFNC
;E D:AGDFNC=0 DELHRN K AGDFNC,DFN Q ;none or two many
;IF THERE WAS THE SAME HRN ASSIGNED TO TWO DIFFERENT PATINETS IN THE SAME FACILITY
;THE LVARS WOULD NOT BE SET AND THE SM1 SUBROUTINE WOULD BE EXECUTED. KILLING AGSDFN
;PREVENTS THIS
;IHS/SD/TPF 5/24/2006 AG*7.1*2 IM20923
E D:AGDFNC=0 DELHRN K AGDFNC,DFN,AGSDFN Q ;none or two many
I $D(^AUPNPAT(AGSDFN)),$D(^DPT(AGSDFN))
E K DFN,AGSDFN Q ;--->
S AGSLNM=$P(^DPT(AGSDFN,0),U)
S AGSLDOB=$P(^DPT(AGSDFN,0),U,3)
S AGSLSSN=$P(^DPT(AGSDFN,0),U,9),AGSLSX=$P(^DPT(AGSDFN,0),U,2)
S AGSLLN=$P(AGSLNM,","),AGSLFN=$P(AGSLNM,",",2)
S:(AGSLFN[" ") AGSLFN=$P(AGSLFN," ",1) ;match against the 1st " " piece
S:(AGSLLN[" ") AGSLLN=$P(AGSLLN," ",1) ;match against the 1st " " piece
S AGSLNM=AGSLLN_","_AGSLFN
ELVAR Q
SM1 ;
;(AGSLSSN=AGSCSSN2) ;does FAC SSN = SSA SSN
;(AGSLSSN=AGSCSSN) ;does FAC SSN = NPIRS SSN
;
I AGSLNM=AGSCNM,AGSLSX=AGSCSX,AGSCDOB=AGSLDOB+17000000 G MATCH
E G NOMATCH
MATCH I 'AGSLSSN,AGSCSSN2,"VA"[AGSCVC S AGSLVC="A" D SETFLG,SETSSN,SEND:'(AGSCSSN1=AGSCSSN2),RA Q
I AGSLSSN,AGSCSSN2,"VA"[AGSCVC,(AGSLSSN=AGSCSSN2) D
.I $P(^AUPNPAT(AGSDFN,0),U,23)]"",$D(^AUTTSSN($P(^(0),U,23),0)),$P(^(0),U)="A" D
..I '(AGSLSSN=AGSCSSN1) D SETFLG,SEND,RR Q ;if previously added and still "A" remain as "A"
.S AGSLVC="V" D SETFLG,SEND:'(AGSLSSN=AGSCSSN1),RV Q
I AGSLSSN,AGSCSSN2,'(AGSLSSN=AGSCSSN2) S AGSLVC="N" D SETFLG,SEND:(AGSCVC="?"),RN Q
I AGSLSSN,'AGSCSSN2,(AGSLSSN=AGSCSSN1) S AGSLVC="X" D SETFLG,RX Q
I AGSLSSN,'AGSCSSN2,'(AGSLSSN=AGSCSSN1) S AGSLVC="P" D SETFLG,SEND:'(AGSLSSN=AGSCSSN1),RP Q
Q
NOMATCH ;
I 'AGSLSSN,AGSCSSN2 S AGSLVC="P" D SETFLG,RP Q
I AGSLSSN,AGSCSSN2,(AGSLSSN=AGSCSSN2) S AGSLVC="D" D SETFLG,RD Q
I AGSLSSN,AGSCSSN2,'(AGSLSSN=AGSCSSN2) S AGSLVC="P" D SETFLG,RP Q
S AGSLVC="P" D SETFLG
ESM1 Q
SETFLG K DIC,DIE,DR
S DA=AGSDFN,DIE="^AUPNPAT(",DR=".23///"_AGSLVC D ^DIE
Q
SETSSN K DIC,DIE,DR Q:"^AUPN"["t" ;REMOVE Q WHEN READY
S DIE="^DPT(",DA=AGSDFN,DR=".09////"_AGSCSSN2 D ^DIE
K DIC,DIE,DR S DIE="^AUPNPAT(",DA=AGSDFN,DR=".24///@" D ^DIE
S ^AGPATCH(DT,AGSSITE,AGSDFN)=""
Q
SEND S AGSFLG=1 Q ;S ^AGPATCH(DT,AGSSITE,AGSDFN)="" Q ;REMOVE Q WHEN READY
R ;REPORTS
RA S ^AGSSTEMP(AGSSITE,"RA",AGSDFN)=AGSCSSN2 Q
RV S ^AGSSTEMP(AGSSITE,"RV",AGSDFN)="" Q
RP S ^AGSSTEMP(AGSSITE,"RP",AGSDFN)=AGSCREC Q
RN S ^AGSSTEMP(AGSSITE,"RN",AGSDFN)=AGSCREC Q
RD S ^AGSSTEMP(AGSSITE,"RD",AGSDFN)=AGSCREC Q
RR S ^AGSSTEMP(AGSSITE,"RR",AGSDFN)=AGSCREC Q
RX S ^AGSSTEMP(AGSSITE,"RX",AGSDFN)=AGSCREC Q
DELHRN ;delete
S AGSINT=$E(AGSCLN)_$E(AGSCFN)
S ^AGSSTEMP(AGSSITE,"DEL",AGSHRN)="RG3^"_AGSSUFAC_"^"_AGSHRN_"^^"_AGSINT_"^"_AGSCSX
Q
EM ;
PRTSSN ;
U AGSPIO
TST ;
I "VA"[$G(AGSLVC) Q
U IO(0) I 'AGSFLG Q
U IO(0) W !,AGSSC
PATL U IO(0) W !,"HRN:",AGSHRN,?15,"LOC:",AGSLSSN,?30,AGSLVC,?35,AGSLNM,?65,AGSLSX,?68,AGSLDOB
PATC W !,"DPS:",AGSCSSN1,?15,"SSA:",AGSCSSN2,?30,AGSCVC,?35,AGSCNM,?65,AGSCSX,?68,AGSCDOB
W !,"sflg: ",AGSFLG
Q
AGSS1 ; IHS/ASDS/EFG - SSN VERIFICATION FROM NPIRS/SSA ;
+1 ;;7.1;PATIENT REGISTRATION;**2**;JAN 31, 2007
+2 ;
S ;START
+1 DO CVARS
DO LVARS
IF $GET(AGSDFN)
DO SM1
+2 QUIT
CVARS ;>SET C VARS modified next line to handle new file format
CVAR SET AGSUFAC=$PIECE(AGSCREC,U)
+1 ;parse out HRN,SSN,Last Name,First Name,Middle Name,DOB
+2 ;modified next 6 lines to handle new file format
+3 SET AGSHRN=+$PIECE(AGSCREC,U,2)
+4 SET AGSCSSN1=$PIECE(AGSCREC,U,3)
+5 SET AGSCLN=$PIECE(AGSCREC,U,4)
+6 SET AGSCFN=$PIECE(AGSCREC,U,5)
+7 SET AGSCMN=$PIECE(AGSCREC,U,6)
+8 SET AGSCDOB=$PIECE(AGSCREC,U,7)
+9 ;NPIRS puts SR JR III as part of the last name
IF AGSCLN[" "
SET AGSCLN=$PIECE(AGSCLN," ")
+10 SET AGSCSX=$PIECE(AGSCREC,U,8)
SET AGSCVC=$PIECE(AGSCREC,U,9)
+11 SET AGSCSSN2=$PIECE(AGSCREC,U,10)
+12 SET AGSCFI=$EXTRACT(AGSCFN)
SET AGSCMI=$EXTRACT(AGSCMN)
SET AGSCLI=$EXTRACT(AGSCLN)
+13 FOR AGSX="AGSCLN","AGSCFN","AGSCMN"
SET AGSY=$LENGTH(@AGSX)
IF AGSY
FOR AGSI=AGSY:-1:0
IF $EXTRACT(@AGSX,AGSI)]" "
QUIT
SET @AGSX=$EXTRACT(@AGSX,0,AGSI-1)
+14 SET AGSCNM=AGSCLN_","_AGSCFN
+15 IF AGSCVC="V"
SET AGSCSSN2=AGSCSSN1
ECVAR QUIT
+1 ;D DSPCVAR ; test loop to read records
+2 ;
LVARS ;>SET LOCAL VARS
+1 ;no hrn in data base
SET DFN=0
SET AGSDFN=0
IF '$DATA(^AUPNPAT("D",AGSHRN))
DO DELHRN
QUIT
+2 ;only process Vs
IF $GET(AGSCVC)'="V"
QUIT
+3 IF +AGSHRN=999999
DO RP
QUIT
LVAR SET (DFN,AGSFLG,AGDFNC)=0
SET AGSLVC=""
FOR
SET DFN=$ORDER(^AUPNPAT("D",AGSHRN,DFN))
IF DFN'>0
QUIT
IF $DATA(^AUPNPAT("D",AGSHRN,DFN,AGSSITE))
SET AGDFNC=AGDFNC+1
SET AGSDFN=DFN
+1 IF AGDFNC=1
KILL AGDFNC
+2 ;E D:AGDFNC=0 DELHRN K AGDFNC,DFN Q ;none or two many
+3 ;IF THERE WAS THE SAME HRN ASSIGNED TO TWO DIFFERENT PATINETS IN THE SAME FACILITY
+4 ;THE LVARS WOULD NOT BE SET AND THE SM1 SUBROUTINE WOULD BE EXECUTED. KILLING AGSDFN
+5 ;PREVENTS THIS
+6 ;IHS/SD/TPF 5/24/2006 AG*7.1*2 IM20923
+7 ;none or two many
IF '$TEST
IF AGDFNC=0
DO DELHRN
KILL AGDFNC,DFN,AGSDFN
QUIT
+8 IF $DATA(^AUPNPAT(AGSDFN))
IF $DATA(^DPT(AGSDFN))
+9 ;--->
IF '$TEST
KILL DFN,AGSDFN
QUIT
+10 SET AGSLNM=$PIECE(^DPT(AGSDFN,0),U)
+11 SET AGSLDOB=$PIECE(^DPT(AGSDFN,0),U,3)
+12 SET AGSLSSN=$PIECE(^DPT(AGSDFN,0),U,9)
SET AGSLSX=$PIECE(^DPT(AGSDFN,0),U,2)
+13 SET AGSLLN=$PIECE(AGSLNM,",")
SET AGSLFN=$PIECE(AGSLNM,",",2)
+14 ;match against the 1st " " piece
IF (AGSLFN[" ")
SET AGSLFN=$PIECE(AGSLFN," ",1)
+15 ;match against the 1st " " piece
IF (AGSLLN[" ")
SET AGSLLN=$PIECE(AGSLLN," ",1)
+16 SET AGSLNM=AGSLLN_","_AGSLFN
ELVAR QUIT
SM1 ;
+1 ;(AGSLSSN=AGSCSSN2) ;does FAC SSN = SSA SSN
+2 ;(AGSLSSN=AGSCSSN) ;does FAC SSN = NPIRS SSN
+3 ;
+4 IF AGSLNM=AGSCNM
IF AGSLSX=AGSCSX
IF AGSCDOB=AGSLDOB+17000000
GOTO MATCH
+5 IF '$TEST
GOTO NOMATCH
MATCH IF 'AGSLSSN
IF AGSCSSN2
IF "VA"[AGSCVC
SET AGSLVC="A"
DO SETFLG
DO SETSSN
IF '(AGSCSSN1=AGSCSSN2)
DO SEND
DO RA
QUIT
+1 IF AGSLSSN
IF AGSCSSN2
IF "VA"[AGSCVC
IF (AGSLSSN=AGSCSSN2)
Begin DoDot:1
+2 IF $PIECE(^AUPNPAT(AGSDFN,0),U,23)]""
IF $DATA(^AUTTSSN($PIECE(^(0),U,23),0))
IF $PIECE(^(0),U)="A"
Begin DoDot:2
+3 ;if previously added and still "A" remain as "A"
IF '(AGSLSSN=AGSCSSN1)
DO SETFLG
DO SEND
DO RR
QUIT
End DoDot:2
+4 SET AGSLVC="V"
DO SETFLG
IF '(AGSLSSN=AGSCSSN1)
DO SEND
DO RV
QUIT
End DoDot:1
+5 IF AGSLSSN
IF AGSCSSN2
IF '(AGSLSSN=AGSCSSN2)
SET AGSLVC="N"
DO SETFLG
IF (AGSCVC="?")
DO SEND
DO RN
QUIT
+6 IF AGSLSSN
IF 'AGSCSSN2
IF (AGSLSSN=AGSCSSN1)
SET AGSLVC="X"
DO SETFLG
DO RX
QUIT
+7 IF AGSLSSN
IF 'AGSCSSN2
IF '(AGSLSSN=AGSCSSN1)
SET AGSLVC="P"
DO SETFLG
IF '(AGSLSSN=AGSCSSN1)
DO SEND
DO RP
QUIT
+8 QUIT
NOMATCH ;
+1 IF 'AGSLSSN
IF AGSCSSN2
SET AGSLVC="P"
DO SETFLG
DO RP
QUIT
+2 IF AGSLSSN
IF AGSCSSN2
IF (AGSLSSN=AGSCSSN2)
SET AGSLVC="D"
DO SETFLG
DO RD
QUIT
+3 IF AGSLSSN
IF AGSCSSN2
IF '(AGSLSSN=AGSCSSN2)
SET AGSLVC="P"
DO SETFLG
DO RP
QUIT
+4 SET AGSLVC="P"
DO SETFLG
ESM1 QUIT
SETFLG KILL DIC,DIE,DR
+1 SET DA=AGSDFN
SET DIE="^AUPNPAT("
SET DR=".23///"_AGSLVC
DO ^DIE
+2 QUIT
SETSSN ;REMOVE Q WHEN READY
KILL DIC,DIE,DR
IF "^AUPN"["t"
QUIT
+1 SET DIE="^DPT("
SET DA=AGSDFN
SET DR=".09////"_AGSCSSN2
DO ^DIE
+2 KILL DIC,DIE,DR
SET DIE="^AUPNPAT("
SET DA=AGSDFN
SET DR=".24///@"
DO ^DIE
+3 SET ^AGPATCH(DT,AGSSITE,AGSDFN)=""
+4 QUIT
SEND ;S ^AGPATCH(DT,AGSSITE,AGSDFN)="" Q ;REMOVE Q WHEN READY
SET AGSFLG=1
QUIT
R ;REPORTS
RA SET ^AGSSTEMP(AGSSITE,"RA",AGSDFN)=AGSCSSN2
QUIT
RV SET ^AGSSTEMP(AGSSITE,"RV",AGSDFN)=""
QUIT
RP SET ^AGSSTEMP(AGSSITE,"RP",AGSDFN)=AGSCREC
QUIT
RN SET ^AGSSTEMP(AGSSITE,"RN",AGSDFN)=AGSCREC
QUIT
RD SET ^AGSSTEMP(AGSSITE,"RD",AGSDFN)=AGSCREC
QUIT
RR SET ^AGSSTEMP(AGSSITE,"RR",AGSDFN)=AGSCREC
QUIT
RX SET ^AGSSTEMP(AGSSITE,"RX",AGSDFN)=AGSCREC
QUIT
DELHRN ;delete
+1 SET AGSINT=$EXTRACT(AGSCLN)_$EXTRACT(AGSCFN)
+2 SET ^AGSSTEMP(AGSSITE,"DEL",AGSHRN)="RG3^"_AGSSUFAC_"^"_AGSHRN_"^^"_AGSINT_"^"_AGSCSX
+3 QUIT
EM ;
PRTSSN ;
+1 USE AGSPIO
TST ;
+1 IF "VA"[$GET(AGSLVC)
QUIT
+2 USE IO(0)
IF 'AGSFLG
QUIT
+3 USE IO(0)
WRITE !,AGSSC
PATL USE IO(0)
WRITE !,"HRN:",AGSHRN,?15,"LOC:",AGSLSSN,?30,AGSLVC,?35,AGSLNM,?65,AGSLSX,?68,AGSLDOB
PATC WRITE !,"DPS:",AGSCSSN1,?15,"SSA:",AGSCSSN2,?30,AGSCVC,?35,AGSCNM,?65,AGSCSX,?68,AGSCDOB
+1 WRITE !,"sflg: ",AGSFLG
+2 QUIT
