AGACALV ; IHS/OIT/NKD - VERIFY AN IHS ELIGIBILITY LETTER ; FEBRUARY 10, 2014
;;7.1;PATIENT REGISTRATION;**11**;AUG 25, 2005;Build 1
EN ;EP
N AGTEXT,AGCNT
F AGCNT=1:1 S AGTEXT=$P($T(HDR+AGCNT^AGACALV),";;",2) Q:AGTEXT="END" D
. W !,AGTEXT
D MAIN
Q
;
MAIN ;MAIN PROCESSING
N AGQUIT
S AGQUIT=0
F Q:AGQUIT D
. N DIR,DTOUT,DUOUT,DIRUT,DIROUT,Y,AGCODE,AGRES
. S DIR(0)="FOU^21"
. S DIR("A")="ENTER THE UNIQUE IDENTIFIER CODE (MINIMUM 21 DIGITS)"
. D ^DIR
. I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) S AGQUIT=1 Q
. S AGCODE=Y
. S AGRES=$$DEC(AGCODE)
. W !!,?16,"LETTER",?35,"RPMS",?60,"RESULTS"
. W !,?16,"------------",?35,"------------",?60,"------------"
. I '$$P1(+AGRES) D PROMPT Q
. I '$$P2(+AGRES,$P(AGRES,U,2))
. I '$$P3(+AGRES,$P(AGRES,U,3))
. D PROMPT
Q
;
PROMPT ;ENTER TO CONTINUE
K DIR S DIR(0)="EO",DIR("A")="Press Enter to continue." D ^DIR K DIR Q
;
P1(AGREC) ;EP - CHECK RECORD NUMBER
N AGRES
;
S AGRES=$S($D(^AGACAL(AGREC,0)):AGREC_U_"PASSED",1:"0^FAILED ***")
;
W !,"RECORD NUMBER: ",?16,AGREC,?30,"...",?35,+AGRES,?60,$P(AGRES,U,2)
;
Q $S(+AGRES:1,1:0)
;
P2(AGREC,AGUID) ;EP - CHECK USER/DT
N AGUSR,AGDT,AGUSRL,AGDTL,AGUSRR,AGDTR
;
S AGUSRL=$P($P(AGUID,"[",2),"__",1),AGDTL=$P($P($P(AGUID,"[",2),"__",2),"]",1)
;
S AGUSRR=$$GET1^DIQ(9009063.5,AGREC,.03,"E"),AGDTR=$$FMTE^XLFDT($$GET1^DIQ(9009063.5,AGREC,.05,"I"))
;
S AGUSR=$S(($E(AGUSRL,1,3)=$E(AGUSRR,1,3))&($E($P(AGUSRL,",",2),1)=$E($P(AGUSRR,",",2),1)):"1^PASSED",1:"0^FAILED ***")
S AGDT=$S(AGDTL=$P(AGDTR,"@",1):"1^PASSED",1:"0^FAILED ***")
;
W !,"USER: ",?16,AGUSRL,?30,"...",?35,$E(AGUSRR,1,23),?60,$P(AGUSR,U,2)
W !,"DATE/TIME: ",?16,AGDTL,?30,"...",?35,$E(AGDTR,1,23),?60,$P(AGDT,U,2)
;
Q $S(+AGUSR++AGDT=2:1,1:0)
;
P3(AGREC,AGPID) ;EP - CHECK PATIENT
N AGDFN,AGNAM,AGDOB,AGSSN,AGNAML,AGDOBL,AGSSNL,AGNAMR,AGDOBR,AGSSNR
;
S AGNAML=$P($P(AGPID,"[",2),"__",1),AGDOBL=$P($P(AGPID,"[",2),"__",2),AGSSNL="XXX-XX-"_$P($P($P(AGPID,"[",2),"__",3),"]",1)
;
S AGDFN=$$GET1^DIQ(9009063.5,AGREC,.01,"I")
S AGNAMR=$$GET1^DIQ(2,AGDFN,.01),AGDOBR=$$FMTE^XLFDT($$GET1^DIQ(2,AGDFN,.03,"I")),AGSSNR=$$GET1^DIQ(9000001,AGDFN,1107.3)
;
S AGNAM=$S(($E(AGNAML,1,3)=$E(AGNAMR,1,3))&($E($P(AGNAML,",",2),1)=$E($P(AGNAMR,",",2),1)):"1^PASSED",1:"0^FAILED ***")
S AGDOB=$S(AGDOBL=AGDOBR:"1^PASSED",1:"0^FAILED ***"),AGSSN=$S(AGSSNL=AGSSNR:"1^PASSED",1:"0^FAILED ***")
;
W !,"PT NAME: ",?16,AGNAML,?30,"...",?35,$E(AGNAMR,1,23),?60,$P(AGNAM,U,2)
W !,"PT DOB: ",?16,AGDOBL,?30,"...",?35,$E(AGDOBR,1,23),?60,$P(AGDOB,U,2)
W !,"PT SSN: ",?16,AGSSNL,?30,"...",?35,$E(AGSSNR,1,23),?60,$P(AGSSN,U,2)
;
Q $S(+AGNAM++AGDOB++AGSSN=3:1,1:0)
;
ENC(AGUSER,AGDT,AGDFN,AGREC) ;EP - CREATE UID
N AGRES,AGCNT,AGRECE
S AGRES=$$UIDE(AGUSER,AGDT)_$$ENC^AUPNPAT(AGDFN),AGRECE=""
S AGREC=$TR(AGREC,"1234567890","7950318246")
S:$L(AGREC>5) AGRECE=$E(AGREC,6,$L(AGREC)),AGREC=$E(AGREC,1,5)
F AGCNT=$L(AGREC):-1:1 S AGRES=$E(AGRES,1,$S((AGCNT-1*4)<$L(AGRES)+1:(AGCNT-1*4),1:$L(AGRES)))_$E(AGREC,AGCNT,AGCNT)_$S((AGCNT-1*4+1)<$L(AGRES):$E(AGRES,(AGCNT-1*4+1),$L(AGRES)),1:"")
S AGRES=AGRES_AGRECE
Q AGRES
;
DEC(AGSTR) ;EP - DECODE UID
N AGRES,AGCNT,AGUID,AGPID,AGREC
S AGRES=AGSTR,AGREC="",AGRECE=""
S:$L(AGRES>25) AGRECE=$E(AGRES,26,$L(AGRES)),AGRES=$E(AGRES,1,25)
F AGCNT=0:1:$L(AGRES)-21 S AGREC=AGREC_$E(AGRES,(4*AGCNT+1),(4*AGCNT+1)),AGRES=$S((4*AGCNT)>0:$E(AGRES,1,(4*AGCNT)),1:"")_$E(AGRES,(4*AGCNT+2),$L(AGRES))
S AGREC=AGREC_AGRECE
S AGREC=$TR(AGREC,"7950318246","1234567890")
Q AGREC_"^"_$$UIDD($E(AGRES,1,8))_"^"_$$DEC^AUPNPAT($E(AGRES,9,20))
;
UIDE(AGUSER,AGDT) ;EP - CREATE ENCRYPTED USER/DT CODE
N AUPNX,AUPNV,X,X1,Y,I
; take 1st 3 chars of name, replace punctuation with numbers, pad out
; to 3 chars
S AUPNX=$E($P($P(^VA(200,AGUSER,0),U),","),1,3)
S AUPNX=$TR(AUPNX," '-.,","01234")
F I=1:1:(3-$L(AUPNX)) S AUPNX=AUPNX_"5"
S AUPNV=AUPNX
;----------
; take 1st initial, 0 if null
S AUPNX=$E($P($P(^VA(200,AGUSER,0),U),",",2)) S:AUPNX="" AUPNX=0
;----------
; concatenate in reverse order
S AUPNV=$E(AUPNV,3)_$E(AUPNV,2)_$E(AUPNV)_AUPNX
;----------
; concatenate fileman date printed (converted to $H/hex format)
S AUPNX=AGDT S:$L(AUPNX)'=7 AUPNX=3991231
S AUPNX=$$FMTH^XLFDT(AUPNX,1)
S X=AUPNX,X1=16 D CNV^XTBASE S Y=$E(Y,1,4)
F I=1:1:(4-$L(Y)) S Y=Y_"-"
S AUPNV=AUPNV_Y
;----------
; shuffle
S AUPNV=$E(AUPNV,3,4)_$E(AUPNV,7,8)_$E(AUPNV,1,2)_$E(AUPNV,5,6)
;----------
; encrypt
S AUPNV=$TR(AUPNV,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","UVWXJKLMYZABQRSTCDGHIEFNOP")
S AUPNV=$TR(AUPNV,"1234567890","8967320415")
;----------
Q AUPNV
UIDD(AGUID) ;EP - DECODE ENCRYPTED USER/DT CODE
N AUPNX,AUPNV,AUPNY,X,X1,Y,I
S AUPNV="["
;----------
; decrypt
S AGUID=$TR(AGUID,"UVWXJKLMYZABQRSTCDGHIEFNOP","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
S AGUID=$TR(AGUID,"8967320415","1234567890")
;----------
; unshuffle
S AGUID=$E(AGUID,5,6)_$E(AGUID,1,2)_$E(AGUID,7,8)_$E(AGUID,3,4)
;----------
; take 1st 3 chars of name, replace numbers with punctuation
S AUPNX=""
F I=3,2,1 S AUPNX=AUPNX_$E(AGUID,I)
S AUPNX=$TR(AUPNX,"01234"," '-.,")
S AUPNY=""
F I=1:1:3 S:$E(AUPNX,I)'="5" AUPNY=AUPNY_$E(AUPNX,I)
S AUPNX=AUPNY_","_$S($E(AGUID,4)'="0":$E(AGUID,4),1:"")
S AUPNV=AUPNV_AUPNX
;----------
; fileman date printed (converted to external format)
S AUPNX=""
S X=$E(AGUID,5,8)
F I=1:1:4 S:$E(X,I)'="-" AUPNX=AUPNX_$E(X,I)
S X=AUPNX,X1=16 D DEC^XTBASE S AUPNX=Y
S AUPNX=$$HTE^XLFDT(AUPNX,1)
S AUPNV=AUPNV_"__"_AUPNX
;----------
S AUPNV=AUPNV_"]"
Q AUPNV
HDR ;HEADER TEXT
;;
;;Verify the authenticity of a printed IHS Eligibility Letter by entering the
;;unique identifier code given to you by the representative of the entity
;;requesting verification.
;;
;;*** NOTE: The codes printed on the IHS Eligibility Letters are unique to ***
;;*** a facility and can only be verified at the site it was printed from. ***
;;
;;END
AGACALV ; IHS/OIT/NKD - VERIFY AN IHS ELIGIBILITY LETTER ; FEBRUARY 10, 2014
+1 ;;7.1;PATIENT REGISTRATION;**11**;AUG 25, 2005;Build 1
EN ;EP
+1 NEW AGTEXT,AGCNT
+2 FOR AGCNT=1:1
SET AGTEXT=$PIECE($TEXT(HDR+AGCNT^AGACALV),";;",2)
IF AGTEXT="END"
QUIT
Begin DoDot:1
+3 WRITE !,AGTEXT
End DoDot:1
+4 DO MAIN
+5 QUIT
+6 ;
MAIN ;MAIN PROCESSING
+1 NEW AGQUIT
+2 SET AGQUIT=0
+3 FOR
IF AGQUIT
QUIT
Begin DoDot:1
+4 NEW DIR,DTOUT,DUOUT,DIRUT,DIROUT,Y,AGCODE,AGRES
+5 SET DIR(0)="FOU^21"
+6 SET DIR("A")="ENTER THE UNIQUE IDENTIFIER CODE (MINIMUM 21 DIGITS)"
+7 DO ^DIR
+8 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
SET AGQUIT=1
QUIT
+9 SET AGCODE=Y
+10 SET AGRES=$$DEC(AGCODE)
+11 WRITE !!,?16,"LETTER",?35,"RPMS",?60,"RESULTS"
+12 WRITE !,?16,"------------",?35,"------------",?60,"------------"
+13 IF '$$P1(+AGRES)
DO PROMPT
QUIT
+14 IF '$$P2(+AGRES,$PIECE(AGRES,U,2))
+15 IF '$$P3(+AGRES,$PIECE(AGRES,U,3))
+16 DO PROMPT
End DoDot:1
+17 QUIT
+18 ;
PROMPT ;ENTER TO CONTINUE
+1 KILL DIR
SET DIR(0)="EO"
SET DIR("A")="Press Enter to continue."
DO ^DIR
KILL DIR
QUIT
+2 ;
P1(AGREC) ;EP - CHECK RECORD NUMBER
+1 NEW AGRES
+2 ;
+3 SET AGRES=$SELECT($DATA(^AGACAL(AGREC,0)):AGREC_U_"PASSED",1:"0^FAILED ***")
+4 ;
+5 WRITE !,"RECORD NUMBER: ",?16,AGREC,?30,"...",?35,+AGRES,?60,$PIECE(AGRES,U,2)
+6 ;
+7 QUIT $SELECT(+AGRES:1,1:0)
+8 ;
P2(AGREC,AGUID) ;EP - CHECK USER/DT
+1 NEW AGUSR,AGDT,AGUSRL,AGDTL,AGUSRR,AGDTR
+2 ;
+3 SET AGUSRL=$PIECE($PIECE(AGUID,"[",2),"__",1)
SET AGDTL=$PIECE($PIECE($PIECE(AGUID,"[",2),"__",2),"]",1)
+4 ;
+5 SET AGUSRR=$$GET1^DIQ(9009063.5,AGREC,.03,"E")
SET AGDTR=$$FMTE^XLFDT($$GET1^DIQ(9009063.5,AGREC,.05,"I"))
+6 ;
+7 SET AGUSR=$SELECT(($EXTRACT(AGUSRL,1,3)=$EXTRACT(AGUSRR,1,3))&($EXTRACT($PIECE(AGUSRL,",",2),1)=$EXTRACT($PIECE(AGUSRR,",",2),1)):"1^PASSED",1:"0^FAILED ***")
+8 SET AGDT=$SELECT(AGDTL=$PIECE(AGDTR,"@",1):"1^PASSED",1:"0^FAILED ***")
+9 ;
+10 WRITE !,"USER: ",?16,AGUSRL,?30,"...",?35,$EXTRACT(AGUSRR,1,23),?60,$PIECE(AGUSR,U,2)
+11 WRITE !,"DATE/TIME: ",?16,AGDTL,?30,"...",?35,$EXTRACT(AGDTR,1,23),?60,$PIECE(AGDT,U,2)
+12 ;
+13 QUIT $SELECT(+AGUSR++AGDT=2:1,1:0)
+14 ;
P3(AGREC,AGPID) ;EP - CHECK PATIENT
+1 NEW AGDFN,AGNAM,AGDOB,AGSSN,AGNAML,AGDOBL,AGSSNL,AGNAMR,AGDOBR,AGSSNR
+2 ;
+3 SET AGNAML=$PIECE($PIECE(AGPID,"[",2),"__",1)
SET AGDOBL=$PIECE($PIECE(AGPID,"[",2),"__",2)
SET AGSSNL="XXX-XX-"_$PIECE($PIECE($PIECE(AGPID,"[",2),"__",3),"]",1)
+4 ;
+5 SET AGDFN=$$GET1^DIQ(9009063.5,AGREC,.01,"I")
+6 SET AGNAMR=$$GET1^DIQ(2,AGDFN,.01)
SET AGDOBR=$$FMTE^XLFDT($$GET1^DIQ(2,AGDFN,.03,"I"))
SET AGSSNR=$$GET1^DIQ(9000001,AGDFN,1107.3)
+7 ;
+8 SET AGNAM=$SELECT(($EXTRACT(AGNAML,1,3)=$EXTRACT(AGNAMR,1,3))&($EXTRACT($PIECE(AGNAML,",",2),1)=$EXTRACT($PIECE(AGNAMR,",",2),1)):"1^PASSED",1:"0^FAILED ***")
+9 SET AGDOB=$SELECT(AGDOBL=AGDOBR:"1^PASSED",1:"0^FAILED ***")
SET AGSSN=$SELECT(AGSSNL=AGSSNR:"1^PASSED",1:"0^FAILED ***")
+10 ;
+11 WRITE !,"PT NAME: ",?16,AGNAML,?30,"...",?35,$EXTRACT(AGNAMR,1,23),?60,$PIECE(AGNAM,U,2)
+12 WRITE !,"PT DOB: ",?16,AGDOBL,?30,"...",?35,$EXTRACT(AGDOBR,1,23),?60,$PIECE(AGDOB,U,2)
+13 WRITE !,"PT SSN: ",?16,AGSSNL,?30,"...",?35,$EXTRACT(AGSSNR,1,23),?60,$PIECE(AGSSN,U,2)
+14 ;
+15 QUIT $SELECT(+AGNAM++AGDOB++AGSSN=3:1,1:0)
+16 ;
ENC(AGUSER,AGDT,AGDFN,AGREC) ;EP - CREATE UID
+1 NEW AGRES,AGCNT,AGRECE
+2 SET AGRES=$$UIDE(AGUSER,AGDT)_$$ENC^AUPNPAT(AGDFN)
SET AGRECE=""
+3 SET AGREC=$TRANSLATE(AGREC,"1234567890","7950318246")
+4 IF $LENGTH(AGREC>5)
SET AGRECE=$EXTRACT(AGREC,6,$LENGTH(AGREC))
SET AGREC=$EXTRACT(AGREC,1,5)
+5 FOR AGCNT=$LENGTH(AGREC):-1:1
SET AGRES=$EXTRACT(AGRES,1,$SELECT((AGCNT-1*4)<$LENGTH(AGRES)+1:(AGCNT-1*4),1:$LENGTH(AGRES)))_$EXTRACT(AGREC,AGCNT,AGCNT)_$SELECT((AGCNT-1*4+1)<$LENGTH(AGRES):$EXTRACT(AGRES,(AGCNT-1*4+1),$LENGTH(AGRES)),1:"")
+6 SET AGRES=AGRES_AGRECE
+7 QUIT AGRES
+8 ;
DEC(AGSTR) ;EP - DECODE UID
+1 NEW AGRES,AGCNT,AGUID,AGPID,AGREC
+2 SET AGRES=AGSTR
SET AGREC=""
SET AGRECE=""
+3 IF $LENGTH(AGRES>25)
SET AGRECE=$EXTRACT(AGRES,26,$LENGTH(AGRES))
SET AGRES=$EXTRACT(AGRES,1,25)
+4 FOR AGCNT=0:1:$LENGTH(AGRES)-21
SET AGREC=AGREC_$EXTRACT(AGRES,(4*AGCNT+1),(4*AGCNT+1))
SET AGRES=$SELECT((4*AGCNT)>0:$EXTRACT(AGRES,1,(4*AGCNT)),1:"")_$EXTRACT(AGRES,(4*AGCNT+2),$LENGTH(AGRES))
+5 SET AGREC=AGREC_AGRECE
+6 SET AGREC=$TRANSLATE(AGREC,"7950318246","1234567890")
+7 QUIT AGREC_"^"_$$UIDD($EXTRACT(AGRES,1,8))_"^"_$$DEC^AUPNPAT($EXTRACT(AGRES,9,20))
+8 ;
UIDE(AGUSER,AGDT) ;EP - CREATE ENCRYPTED USER/DT CODE
+1 NEW AUPNX,AUPNV,X,X1,Y,I
+2 ; take 1st 3 chars of name, replace punctuation with numbers, pad out
+3 ; to 3 chars
+4 SET AUPNX=$EXTRACT($PIECE($PIECE(^VA(200,AGUSER,0),U),","),1,3)
+5 SET AUPNX=$TRANSLATE(AUPNX," '-.,","01234")
+6 FOR I=1:1:(3-$LENGTH(AUPNX))
SET AUPNX=AUPNX_"5"
+7 SET AUPNV=AUPNX
+8 ;----------
+9 ; take 1st initial, 0 if null
+10 SET AUPNX=$EXTRACT($PIECE($PIECE(^VA(200,AGUSER,0),U),",",2))
IF AUPNX=""
SET AUPNX=0
+11 ;----------
+12 ; concatenate in reverse order
+13 SET AUPNV=$EXTRACT(AUPNV,3)_$EXTRACT(AUPNV,2)_$EXTRACT(AUPNV)_AUPNX
+14 ;----------
+15 ; concatenate fileman date printed (converted to $H/hex format)
+16 SET AUPNX=AGDT
IF $LENGTH(AUPNX)'=7
SET AUPNX=3991231
+17 SET AUPNX=$$FMTH^XLFDT(AUPNX,1)
+18 SET X=AUPNX
SET X1=16
DO CNV^XTBASE
SET Y=$EXTRACT(Y,1,4)
+19 FOR I=1:1:(4-$LENGTH(Y))
SET Y=Y_"-"
+20 SET AUPNV=AUPNV_Y
+21 ;----------
+22 ; shuffle
+23 SET AUPNV=$EXTRACT(AUPNV,3,4)_$EXTRACT(AUPNV,7,8)_$EXTRACT(AUPNV,1,2)_$EXTRACT(AUPNV,5,6)
+24 ;----------
+25 ; encrypt
+26 SET AUPNV=$TRANSLATE(AUPNV,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","UVWXJKLMYZABQRSTCDGHIEFNOP")
+27 SET AUPNV=$TRANSLATE(AUPNV,"1234567890","8967320415")
+28 ;----------
+29 QUIT AUPNV
UIDD(AGUID) ;EP - DECODE ENCRYPTED USER/DT CODE
+1 NEW AUPNX,AUPNV,AUPNY,X,X1,Y,I
+2 SET AUPNV="["
+3 ;----------
+4 ; decrypt
+5 SET AGUID=$TRANSLATE(AGUID,"UVWXJKLMYZABQRSTCDGHIEFNOP","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+6 SET AGUID=$TRANSLATE(AGUID,"8967320415","1234567890")
+7 ;----------
+8 ; unshuffle
+9 SET AGUID=$EXTRACT(AGUID,5,6)_$EXTRACT(AGUID,1,2)_$EXTRACT(AGUID,7,8)_$EXTRACT(AGUID,3,4)
+10 ;----------
+11 ; take 1st 3 chars of name, replace numbers with punctuation
+12 SET AUPNX=""
+13 FOR I=3,2,1
SET AUPNX=AUPNX_$EXTRACT(AGUID,I)
+14 SET AUPNX=$TRANSLATE(AUPNX,"01234"," '-.,")
+15 SET AUPNY=""
+16 FOR I=1:1:3
IF $EXTRACT(AUPNX,I)'="5"
SET AUPNY=AUPNY_$EXTRACT(AUPNX,I)
+17 SET AUPNX=AUPNY_","_$SELECT($EXTRACT(AGUID,4)'="0":$EXTRACT(AGUID,4),1:"")
+18 SET AUPNV=AUPNV_AUPNX
+19 ;----------
+20 ; fileman date printed (converted to external format)
+21 SET AUPNX=""
+22 SET X=$EXTRACT(AGUID,5,8)
+23 FOR I=1:1:4
IF $EXTRACT(X,I)'="-"
SET AUPNX=AUPNX_$EXTRACT(X,I)
+24 SET X=AUPNX
SET X1=16
DO DEC^XTBASE
SET AUPNX=Y
+25 SET AUPNX=$$HTE^XLFDT(AUPNX,1)
+26 SET AUPNV=AUPNV_"__"_AUPNX
+27 ;----------
+28 SET AUPNV=AUPNV_"]"
+29 QUIT AUPNV
HDR ;HEADER TEXT
+1 ;;
+2 ;;Verify the authenticity of a printed IHS Eligibility Letter by entering the
+3 ;;unique identifier code given to you by the representative of the entity
+4 ;;requesting verification.
+5 ;;
+6 ;;*** NOTE: The codes printed on the IHS Eligibility Letters are unique to ***
+7 ;;*** a facility and can only be verified at the site it was printed from. ***
+8 ;;
+9 ;;END
