- 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
