PSOERPT1 ;BIRM/MFR - eRx Single Patient Medication Queue Supporting API's ; 12/10/22 10:57am
;;7.0;OUTPATIENT PHARMACY;**700,750,746**;DEC 1997;Build 106
;
SETHDR() ; - Displays the Header Line
N HDR,SRTORD,SRTPOS
;
S HDR="#",$E(HDR,5)="ERX ID",$E(HDR,19)="DRUG NAME",$E(HDR,42)="PROVIDER NAME",$E(HDR,59)="REC.DATE"
S $E(HDR,68)="STA",$E(HDR,72)="PT",$E(HDR,75)="PR",$E(HDR,78)="DR "
D INSTR^VALM1(IORVON_HDR_IOINORM,1,4)
S SRTORD=$S(PSORDER="A":"^",1:"v")
I PSOSRTBY="ALL" D
. D INSTR^VALM1(IOINHI_IORVON_SRTORD_IOINORM,74,4)
. D INSTR^VALM1(IOINHI_IORVON_SRTORD_IOINORM,77,4)
. D INSTR^VALM1(IOINHI_IORVON_SRTORD_IOINORM,80,4)
E D
. S SRTPOS=$S(PSOSRTBY="ID":11,PSOSRTBY="DR":28,PSOSRTBY="PR":55,PSOSRTBY="RE":67,PSOSRTBY="STA":71,PSOSRTBY="PAM":74,PSOSRTBY="PRM":77,1:80)
. D INSTR^VALM1(IOINHI_IORVON_SRTORD_IOINORM,SRTPOS,4)
Q
;
SETSORT(FIELD) ;Sets the data sorted by the FIELD specified
; Input: FIELD - Sort By Field
N RECDAT,ERXIEN,CSGROUP,SORT,RELMSGID
K ^TMP("PSOERPTS",$J),^TMP("PSOERINC",$J)
; Loading eRx's (file #52.49)
S ERXIEN=0,RECDAT=$$FMADD^XLFDT(DT,-PSOLKBKD)
F S RECDAT=$O(^PS(52.49,"PAT2",EPATIEN,RECDAT)) Q:'RECDAT D
. F S ERXIEN=$O(^PS(52.49,"PAT2",EPATIEN,RECDAT,ERXIEN)) Q:'ERXIEN D
. . D SETITEM(ERXIEN,FIELD) S ^TMP("PSOERINC",$J,ERXIEN)=""
. . S RELMSGID=0 F S RELMSGID=$O(^PS(52.49,ERXIEN,201,"B",RELMSGID)) Q:'RELMSGID D
. . . I $$GET1^DIQ(52.49,RELMSGID,.03,"I")<$$FMADD^XLFDT(DT,-PSOLKBKD) Q
. . . I $D(^TMP("PSOERINC",$J,RELMSGID)) Q
. . . D SETITEM(RELMSGID,FIELD) S ^TMP("PSOERINC",$J,RELMSGID)=""
K ^TMP("PSOERINC",$J)
Q
;
SETITEM(ERXIEN,FIELD) ; Adds an eRx Record to the Sorted List
; Input: ERXIEN - eRx IEN - Pointer to #52.49
; FIELD - Sort By field
N STATUS,MSGTYPE,ERXID,DRUG,CSGROUP,PROVIDER,PATMTCH,PROMTCH,DRUMTCH,Z,X,MSGDTTM
S STATUS=$$GET1^DIQ(52.49,ERXIEN,1)
; Actionable/Non-Actionable Status
I '$G(PSOALLST),$F(",RJ,RM,REM,PR,E,RXA,CXA,CAA,CAN,CXP,RXP,RXA,ICA,CNP,CRP,CRC,RRC,CXC,CNE,CRN,CRR,CRX,CXQ,RXA,RXC,RRN,RRX,RRR,RRP,IRA,",","_$E(STATUS,1,3)_",") Q
S MSGTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
S MSGDTTM=$$GET1^DIQ(52.49,ERXIEN,.03,"I")
; Skip Change Request records w/ Processing Error Status
I '$G(PSOALLST),MSGTYPE="CR",STATUS="CRE" Q
; Skip Inbound errors except RRE or CRE records
I '$G(PSOALLST),MSGTYPE="IE",(STATUS'="RRE"),(STATUS'="CRE") Q
; Related Institution Filter (Non-MbM sites only)
I '$G(MBMSITE),PSNPINST'=+$$GET1^DIQ(52.49,ERXIEN,24.1,"I") Q
; Controlled Substance Prompts Filter
I $G(PSOCSERX)="CS",'$$GET1^DIQ(52.49,ERXIEN,95.1,"I") Q
I $G(PSOCSERX)="Non-CS",$$GET1^DIQ(52.49,ERXIEN,95.1,"I") Q
I '$$CSFILTER^PSOERXUT(ERXIEN) Q
S ERXID=$$GET1^DIQ(52.49,ERXIEN,.01)
S DRUG=$$GETDRUG^PSOERXU5(ERXIEN) I DRUG="" S DRUG=$S(MSGTYPE="IE":"<<INBOUND ERROR>>",1:"N/A")
S CSGROUP=$S('PSOCSGRP:"ALL",$$GET1^DIQ(52.49,ERXIEN,95.1,"I"):"CS",1:"NON-CS")
S PROVIDER=$$GET1^DIQ(52.49,ERXIEN,2.1) I PROVIDER="" S PROVIDER=$$GET1^DIQ(52.48,$$GETPROV^PSOERXU5(ERXIEN),.01)
S PATMTCH=$$MATCH^PSOERPT2("PAM",ERXIEN)
S PROMTCH=$$MATCH^PSOERPT2("PRM",ERXIEN)
S DRUMTCH=$$MATCH^PSOERPT2("DRM",ERXIEN)
S Z="",$P(Z,"^")=$E(DRUG,1,34),$P(Z,"^",2)=$E(PROVIDER,1,16),$P(Z,"^",3)=$$FMTE^XLFDT(MSGDTTM\1,"2Z")
S $P(Z,"^",4)=STATUS,$P(Z,"^",5)=PATMTCH,$P(Z,"^",6)=PROMTCH,$P(Z,"^",7)=DRUMTCH
I FIELD="ID" S SORT=$S(ERXID:1000000000000+ERXID,1:ERXID)_" "_ERXIEN
I FIELD="DR" S SORT=$$UP^XLFSTR(DRUG)_" "_ERXIEN
I FIELD="PR" S SORT=PROVIDER_" "_ERXIEN
I FIELD="RE" S SORT=MSGDTTM_" "_ERXIEN
I FIELD="STA" S SORT=STATUS_" "_RECDAT
I FIELD="PAM" S X=$P(PATMTCH,"^"),SORT=$S(X="":1,X="M":2,1:3)_ERXIEN
I FIELD="PRM" S X=$P(PROMTCH,"^"),SORT=$S(X="":1,X="M":2,1:3)_ERXIEN
I FIELD="DRM" S X=$P(DRUMTCH,"^"),SORT=$S(X="":1,X="M":2,1:3)_ERXIEN
I FIELD="ALL" S SORT=$$MATCHSRT^PSOERPT2($P(PATMTCH,"^"),$P(PROMTCH,"^"),$P(DRUMTCH,"^"))_ERXIEN
S ^TMP("PSOERPTS",$J,CSGROUP,SORT)=Z
S ^TMP("PSOERPTS",$J,CSGROUP,SORT,"ERXIEN")=ERXIEN
I $P(PATMTCH,"^",2) S ^TMP("PSOERPTS",$J,CSGROUP,SORT,"PATAM")=1
I $P(PROMTCH,"^",2) S ^TMP("PSOERPTS",$J,CSGROUP,SORT,"PROAM")=1
I $P(PROMTCH,"^",3) S ^TMP("PSOERPTS",$J,CSGROUP,SORT,"PROAV")=1
I $P(DRUMTCH,"^",2) S ^TMP("PSOERPTS",$J,CSGROUP,SORT,"DRUAM")=1
Q
;
MATCHSUG(ERXIEN,VIEW) ; Match Suggestion Prompt
; Input: ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
; (o)VIEW - View Only Mode (1:YES,0/null: NO)
;Output: VISTAPAT - VistA Patient (Pointer to #2) or 0 (Not selected or no suggestion on file)
;
N MATCHSUG,MATCHCNT,LSTMTCH,LSTERXID,CNT,ERXPAT,VPAT,QUIT,DIR,DIRUT,DIROUT,X,Y,II
S ERXPAT=+$$GET1^DIQ(52.49,+$G(ERXIEN),.04,"I") I 'ERXPAT Q 0
S (MATCHSUG,MATCHCNT,CNT,VPAT,QUIT)=0
F S VPAT=$O(^PS(52.49,"APATVPAT",ERXPAT,VPAT)) Q:'VPAT S:'$$DEAD^PSONVARP(VPAT) MATCHCNT=MATCHCNT+1
I MATCHCNT>3 S MATCHCNT=3
F S VPAT=$O(^PS(52.49,"APATVPAT",ERXPAT,VPAT)) Q:'VPAT D I MATCHSUG!(CNT>2)!QUIT Q
. I $$DEAD^PSONVARP(VPAT) Q
. S CNT=CNT+1
. S LSTMTCH=$O(^PS(52.49,"APATVPAT",ERXPAT,VPAT,9999999),-1) I 'LSTMTCH Q
. S LSTERXID=$O(^PS(52.49,"APATVPAT",ERXPAT,VPAT,LSTMTCH,0)) I 'LSTERXID!(LSTERXID=ERXIEN) Q
. D CMPPAT(ERXIEN,VPAT,LSTERXID,CNT_"^"_MATCHCNT)
. K DIR S DIR(0)="SOA^"_$S('$G(VIEW):"A:ACCEPT;",1:"")_$S(MATCHCNT>1&(MATCHCNT'=CNT):"N:NEXT;",1:"")_"F:FORGET;E:EXIT"
. S DIR("A")="ACTION on SUGGESTION: "_$S('$G(VIEW):"(A)CCEPT ",1:"")_$S(MATCHCNT>1&(MATCHCNT'=CNT):"(N)EXT ",1:"")_"(F)ORGET (E)XIT: "
. S DIR("B")=$S(MATCHCNT>1&(MATCHCNT'=CNT):"NEXT",1:"EXIT")
. S II=0
. I '$G(VIEW) D
. . S II=II+1,DIR("?",II)=" ACCEPT - Accepts the suggested VistA Patient and matches it to the eRx"
. I MATCHCNT>1&(MATCHCNT'=CNT) D
. . S II=II+1,DIR("?",II)=" NEXT - Ignores this suggested VistA Patient and view the next one"
. S II=II+1,DIR("?",II)=" FORGET - Forgets this suggested VistA Patient so that it is not presented"
. S II=II+1,DIR("?",II)=" again in the future to any user"
. S DIR("?")=" EXIT - Exit and proceed to match the VistA Patient manually"
. D ^DIR I $D(DIRUT)!$D(DIROUT)!(Y="E") S QUIT=1 Q
. I Y="A" S MATCHSUG=VPAT Q
. I Y="N" W ! Q
. I Y="F" D
. . K DIR S DIR(0)="SA^Y:YES;N:NO",DIR("B")="NO"
. . S DIR("A")="Are you sure this validated match should be forgotten? "
. . S DIR("?")="This VistA Patient was previously matched and validated as a valid match for this eRx Patient. Once you forget this match it will no longer be suggested as a match for this eRx patient."
. . W ! D ^DIR I $D(DIRUT)!$D(DIROUT)!(Y="N") S VPAT=VPAT-1,CNT=CNT-1 W ! Q
. . W !?50,"Forgetting..." K ^PS(52.49,"APATVPAT",ERXPAT,VPAT) H 1 W "done." W ! Q
Q MATCHSUG
;
CMPPAT(ERXIEN,VISTAPAT,LSTERXID,COUNTER) ; Display the Comparison Between eRx and VistA Patients
;Input: ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
; VISTAPAT - VistA Patient (Pointer to #2)
; (o)LSTERXID - Last eRx IEN with the Match (Pointer to #52.49)
; (o)COUNTER - P1: Entry # | P2: Number of Entries
I '$D(^PS(52.49,+$G(ERXIEN),0))!'$D(^DPT(+$G(VISTAPAT),0)) Q
N X,XX,LINE
I $G(LSTERXID) D
. W !?55,"|Sugg. " W $G(IOINHI)_+$G(COUNTER)_$G(IOINORM)_" of "_$G(IOINHI)_$P($G(COUNTER),"^",2)_$G(IOINORM)
. W " - ",$G(IOINHI)_$$FMTE^XLFDT($$GET1^DIQ(52.49,LSTERXID,1.14,"I")\1,"2Z")_$G(IOINORM),"|"
W !,$G(IORVON)_"ERX PATIENT"_$G(IORVOFF),?41,$G(IORVON)_"VISTA PATIENT"_$G(IORVOFF)
I $G(LSTERXID) W ?55,"|From eRx#: "_$G(IOINHI)_$$GET1^DIQ(52.49,LSTERXID,.01)_$G(IOINORM),?79,"|"
S $P(XX,"_",81)="" W !,XX
D SETPAT^PSOERUT0("RS",ERXIEN,VISTAPAT)
Q
;
CSERXS() ; Returns whether there are CS eRx on the list or not
N CSERXS,LINE,ERXIEN
S CSERXS=0
S LINE=0 F S LINE=$O(^TMP("PSOERPT0",$J,LINE)) Q:'LINE D I CSERXS Q
. S SEQ=+$G(^TMP("PSOERPT0",$J,LINE,0)) I 'SEQ Q
. S ERXIEN=+$G(^TMP("PSOERPT0",$J,SEQ,"ERXIEN"))
. ;DO NOT FILL record
. I $$GET1^DIQ(52.49,+$G(ERXIEN),10.5,"I")=2 Q
. I $$GET1^DIQ(52.49,ERXIEN,95.1,"I") S CSERXS=1
Q CSERXS
;
VAPATIEN() ; Returns the VistA Patient IEN or 0 (No VistA Patient Selected) or -1 (Different VistA Patients Selected)
N VAPATIEN,LINE,ERXIEN,DFN,SEQ
S VAPATIEN=""
S LINE=0 F S LINE=$O(^TMP("PSOERPT0",$J,LINE)) Q:'LINE D I VAPATIEN=-1 Q
. S SEQ=+$G(^TMP("PSOERPT0",$J,LINE,0)) I 'SEQ Q
. S ERXIEN=+$G(^TMP("PSOERPT0",$J,SEQ,"ERXIEN"))
. S DFN=+$$GET1^DIQ(52.49,ERXIEN,.05,"I") I DFN,'VAPATIEN S VAPATIEN=DFN
. I DFN,DFN'=VAPATIEN S VAPATIEN=-1
Q VAPATIEN
;
OPACCESS(OPTION,USER,LIST) ; Returns whether the current user has priviledge to Perform a given action on a list of entries
; Input: OPTION - Option to be checked
; USER - Pointer to NEW PERSON file (#200)
; LIST - List of eRX Records to be checked
;Output: 1 - User has access | 0 - User does not have access
N OPACCESS,SEQ,ERXIEN,PSOIEN
S OPACCESS=1
S SEQ=0 F S SEQ=$O(LIST(SEQ)) Q:'SEQ D I 'OPACCESS Q
. S ERXIEN=+LIST(SEQ)
. ;DO NOT FILL record
. I $$GET1^DIQ(52.49,+$G(ERXIEN),10.5,"I")=2 S OPACCESS=0
. S PSOIEN=ERXIEN
. S OPACCESS=$$OPACCESS^PSOERXU7(OPTION,USER,ERXIEN)
Q OPACCESS
;
ALRDYVAL() ; Returns whether at least one record from the list has already been validated
N ALRDYVAL,LINE,ERXIEN,SEQ
S ALRDYVAL=0
S LINE=0 F S LINE=$O(^TMP("PSOERPT0",$J,LINE)) Q:'LINE D I ALRDYVAL Q
. S SEQ=+$G(^TMP("PSOERPT0",$J,LINE,0)) I 'SEQ Q
. S ERXIEN=+$G(^TMP("PSOERPT0",$J,SEQ,"ERXIEN"))
. ;DO NOT FILL record
. I $$GET1^DIQ(52.49,+$G(ERXIEN),10.5,"I")=2 Q
. S ALRDYVAL=+$$GET1^DIQ(52.49,ERXIEN,1.7,"I")
Q ALRDYVAL
;
VIDEO() ; Changes the Video Attributes for the list
N I,LN
; The command below is used to circumvent a bug with Reverse Video in ListMan
; (Related to Filtered BY line in the header)
D CNTRL^VALM10(1,1,79,IORVOFF,IOINORM)
;
I '$D(IORVOFF)!'$D(VALMEVL) Q
F I=0:1:LINE D CNTRL^VALM10(I,1,80,IOINORM,IOINORM)
; - Highlighting the PRESCRIPTION line if SIG is displayed
F I=1:1:LINE D
. I $D(HIGHLN(I)),$D(UNDLN(I)) D CNTRL^VALM10(I,1,80,IOUON_IOINHI,IOUOFF_IOINORM) Q
. I $D(HIGHLN(I)) D CNTRL^VALM10(I,1,80,IOINHI,IOINORM)
. I $D(UNDLN(I)) D CNTRL^VALM10(I,1,80,IOUON,IOINORM)
; - Highlighting the group lines (order type and status)
I $D(GRPLN) D
. S LN=0 F I=1:1 S LN=$O(GRPLN(LN)) Q:'LN D
. . S LBL=GRPLN(LN),POS=41-($L(LBL)\2)
. . D CNTRL^VALM10(LN,1,POS-1,IOUON,IOINORM)
. . D CNTRL^VALM10(LN,POS,$L(LBL),IORVON,IORVOFF_IOINORM)
. . D CNTRL^VALM10(LN,POS+$L(LBL),81-POS-$L(LBL),IOUON,IOINORM)
; - Highlighting Auto To Manual Match
S LN=0 F I=1:1 S LN=$O(PTMTCHLN(LN)) Q:'LN D
. D CNTRL^VALM10(LN,72,1,IOINHI,IOINORM)
S LN=0 F I=1:1 S LN=$O(PRMTCHLN(LN)) Q:'LN D
. D CNTRL^VALM10(LN,75,1,IOINHI,IOINORM)
S LN=0 F I=1:1 S LN=$O(PRVALLN(LN)) Q:'LN D
. D CNTRL^VALM10(LN,76,1,IOINHI,IOINORM)
S LN=0 F I=1:1 S LN=$O(DRMTCHLN(LN)) Q:'LN D
. D CNTRL^VALM10(LN,78,1,IOINHI,IOINORM)
Q
;
ERXLST(RANGE,ERXLST) ; Given a Range of List Item returns the list of eRx's in an Array
; Input: RANGE - User Selected Range (ex: '1-5'; '2,5,8,10'; '1-5,11-15', etc)
;Output: ERXLST - Array with the selected list of eRx IEN's (Pointer to #52.49) - ERXLST(ERXIEN)
;
N L1,LINE,INVALID,SEG
S INVALID=0 K ERXLST
F L1=1:1:$L(RANGE,",") D
. S SEG=$P(RANGE,",",L1) I SEG="" Q
. I SEG["-" D
. . F LINE=+$P(SEG,"-"):1:+$P(SEG,"-",2) D
. . . S ERXIEN=+$G(^TMP("PSOERPT0",$J,LINE,"ERXIEN")) I 'ERXIEN S INVALID=1 Q
. . . S ERXLST(LINE)=ERXIEN
. E D
. . S ERXIEN=+$G(^TMP("PSOERPT0",$J,+SEG,"ERXIEN")) I 'ERXIEN S INVALID=1 Q
. . S ERXLST(+SEG)=ERXIEN
K:INVALID ERXLST
Q
;
LSTERXS(ERXLST,ISSONLY,DISPSEQ) ; Given a list of eRx IENs (array passed in by Reference) it displays a list
;Input: (r) ERXLST - Array with the list of eRx IEN's to be listed(Pointer to #52.49) - ERXLST(ERXIEN)
; (o) ISSONLY - List Entries with Issues Only? (1: YES | 0: NO)
; (o) DISPSEQ - Display the Sequence #? (1: YES | 0: NO)
N SEQ,ERXIEN,HDR,XX,CNT,DIR
S HDR=$S(DISPSEQ:"#",1:""),$E(HDR,$S(DISPSEQ:5,1:1))="ERX ID",$E(HDR,17)="DRUG NAME",$E(HDR,52)="PROVIDER",$E(HDR,75)="STS"
S $P(XX,"-",80)="" W !,HDR,!,XX
S (SEQ,CNT)=0 F S SEQ=$O(ERXLST(SEQ)) Q:'SEQ D
. S ERXIEN=+ERXLST(SEQ)
. I $G(ISSONLY),$P($G(ERXLST(SEQ)),"^",2)="" Q
. W !,$S(DISPSEQ:SEQ_$S($$GET1^DIQ(52.49,ERXIEN,95.1,"I"):"]",1:"."),1:""),?$S(DISPSEQ:4,1:0),$$GET1^DIQ(52.49,ERXIEN,.01)
. W ?16,$E($S($$GETDRUG^PSOERXU5(ERXIEN)'="":$$GETDRUG^PSOERXU5(ERXIEN),1:"N/A"),1,34)
. W ?51,$E($$GET1^DIQ(52.49,ERXIEN,2.1),1,22)
. W ?74,$$GET1^DIQ(52.49,ERXIEN,1)
. I $P($G(ERXLST(SEQ)),"^",2)'="" D
. . S CNT=CNT+1 W !,"REASON: ",$P($G(ERXLST(SEQ)),"^",2)
. S CNT=CNT+1 I '(CNT#18) D PAUSE^VALM1 W !,HDR,!,XX
Q
;
PATIDS ; Patient Lookup Identifiers Display (set on DIC("W"))
N Z
W " ",$$FMTE^XLFDT($P(^(0),U,3),"5Z")," ",$P(^(0),U,9)
S Z=$G(^(.11)) I $P(Z,U,4)'="" W " ",$P(Z,U,4) I $P(Z,U,5) W ",",$P(^DIC(5,+$P(Z,U,5),0),U,2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERPT1 13018 printed Oct 16, 2024@18:28:30 Page 2
PSOERPT1 ;BIRM/MFR - eRx Single Patient Medication Queue Supporting API's ; 12/10/22 10:57am
+1 ;;7.0;OUTPATIENT PHARMACY;**700,750,746**;DEC 1997;Build 106
+2 ;
SETHDR() ; - Displays the Header Line
+1 NEW HDR,SRTORD,SRTPOS
+2 ;
+3 SET HDR="#"
SET $EXTRACT(HDR,5)="ERX ID"
SET $EXTRACT(HDR,19)="DRUG NAME"
SET $EXTRACT(HDR,42)="PROVIDER NAME"
SET $EXTRACT(HDR,59)="REC.DATE"
+4 SET $EXTRACT(HDR,68)="STA"
SET $EXTRACT(HDR,72)="PT"
SET $EXTRACT(HDR,75)="PR"
SET $EXTRACT(HDR,78)="DR "
+5 DO INSTR^VALM1(IORVON_HDR_IOINORM,1,4)
+6 SET SRTORD=$SELECT(PSORDER="A":"^",1:"v")
+7 IF PSOSRTBY="ALL"
Begin DoDot:1
+8 DO INSTR^VALM1(IOINHI_IORVON_SRTORD_IOINORM,74,4)
+9 DO INSTR^VALM1(IOINHI_IORVON_SRTORD_IOINORM,77,4)
+10 DO INSTR^VALM1(IOINHI_IORVON_SRTORD_IOINORM,80,4)
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 SET SRTPOS=$SELECT(PSOSRTBY="ID":11,PSOSRTBY="DR":28,PSOSRTBY="PR":55,PSOSRTBY="RE":67,PSOSRTBY="STA":71,PSOSRTBY="PAM":74,PSOSRTBY="PRM":77,1:80)
+13 DO INSTR^VALM1(IOINHI_IORVON_SRTORD_IOINORM,SRTPOS,4)
End DoDot:1
+14 QUIT
+15 ;
SETSORT(FIELD) ;Sets the data sorted by the FIELD specified
+1 ; Input: FIELD - Sort By Field
+2 NEW RECDAT,ERXIEN,CSGROUP,SORT,RELMSGID
+3 KILL ^TMP("PSOERPTS",$JOB),^TMP("PSOERINC",$JOB)
+4 ; Loading eRx's (file #52.49)
+5 SET ERXIEN=0
SET RECDAT=$$FMADD^XLFDT(DT,-PSOLKBKD)
+6 FOR
SET RECDAT=$ORDER(^PS(52.49,"PAT2",EPATIEN,RECDAT))
if 'RECDAT
QUIT
Begin DoDot:1
+7 FOR
SET ERXIEN=$ORDER(^PS(52.49,"PAT2",EPATIEN,RECDAT,ERXIEN))
if 'ERXIEN
QUIT
Begin DoDot:2
+8 DO SETITEM(ERXIEN,FIELD)
SET ^TMP("PSOERINC",$JOB,ERXIEN)=""
+9 SET RELMSGID=0
FOR
SET RELMSGID=$ORDER(^PS(52.49,ERXIEN,201,"B",RELMSGID))
if 'RELMSGID
QUIT
Begin DoDot:3
+10 IF $$GET1^DIQ(52.49,RELMSGID,.03,"I")<$$FMADD^XLFDT(DT,-PSOLKBKD)
QUIT
+11 IF $DATA(^TMP("PSOERINC",$JOB,RELMSGID))
QUIT
+12 DO SETITEM(RELMSGID,FIELD)
SET ^TMP("PSOERINC",$JOB,RELMSGID)=""
End DoDot:3
End DoDot:2
End DoDot:1
+13 KILL ^TMP("PSOERINC",$JOB)
+14 QUIT
+15 ;
SETITEM(ERXIEN,FIELD) ; Adds an eRx Record to the Sorted List
+1 ; Input: ERXIEN - eRx IEN - Pointer to #52.49
+2 ; FIELD - Sort By field
+3 NEW STATUS,MSGTYPE,ERXID,DRUG,CSGROUP,PROVIDER,PATMTCH,PROMTCH,DRUMTCH,Z,X,MSGDTTM
+4 SET STATUS=$$GET1^DIQ(52.49,ERXIEN,1)
+5 ; Actionable/Non-Actionable Status
+6 IF '$GET(PSOALLST)
IF $FIND(",RJ,RM,REM,PR,E,RXA,CXA,CAA,CAN,CXP,RXP,RXA,ICA,CNP,CRP,CRC,RRC,CXC,CNE,CRN,CRR,CRX,CXQ,RXA,RXC,RRN,RRX,RRR,RRP,IRA,",","_$EXTRACT(STATUS,1,3)_",")
QUIT
+7 SET MSGTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+8 SET MSGDTTM=$$GET1^DIQ(52.49,ERXIEN,.03,"I")
+9 ; Skip Change Request records w/ Processing Error Status
+10 IF '$GET(PSOALLST)
IF MSGTYPE="CR"
IF STATUS="CRE"
QUIT
+11 ; Skip Inbound errors except RRE or CRE records
+12 IF '$GET(PSOALLST)
IF MSGTYPE="IE"
IF (STATUS'="RRE")
IF (STATUS'="CRE")
QUIT
+13 ; Related Institution Filter (Non-MbM sites only)
+14 IF '$GET(MBMSITE)
IF PSNPINST'=+$$GET1^DIQ(52.49,ERXIEN,24.1,"I")
QUIT
+15 ; Controlled Substance Prompts Filter
+16 IF $GET(PSOCSERX)="CS"
IF '$$GET1^DIQ(52.49,ERXIEN,95.1,"I")
QUIT
+17 IF $GET(PSOCSERX)="Non-CS"
IF $$GET1^DIQ(52.49,ERXIEN,95.1,"I")
QUIT
+18 IF '$$CSFILTER^PSOERXUT(ERXIEN)
QUIT
+19 SET ERXID=$$GET1^DIQ(52.49,ERXIEN,.01)
+20 SET DRUG=$$GETDRUG^PSOERXU5(ERXIEN)
IF DRUG=""
SET DRUG=$SELECT(MSGTYPE="IE":"<<INBOUND ERROR>>",1:"N/A")
+21 SET CSGROUP=$SELECT('PSOCSGRP:"ALL",$$GET1^DIQ(52.49,ERXIEN,95.1,"I"):"CS",1:"NON-CS")
+22 SET PROVIDER=$$GET1^DIQ(52.49,ERXIEN,2.1)
IF PROVIDER=""
SET PROVIDER=$$GET1^DIQ(52.48,$$GETPROV^PSOERXU5(ERXIEN),.01)
+23 SET PATMTCH=$$MATCH^PSOERPT2("PAM",ERXIEN)
+24 SET PROMTCH=$$MATCH^PSOERPT2("PRM",ERXIEN)
+25 SET DRUMTCH=$$MATCH^PSOERPT2("DRM",ERXIEN)
+26 SET Z=""
SET $PIECE(Z,"^")=$EXTRACT(DRUG,1,34)
SET $PIECE(Z,"^",2)=$EXTRACT(PROVIDER,1,16)
SET $PIECE(Z,"^",3)=$$FMTE^XLFDT(MSGDTTM\1,"2Z")
+27 SET $PIECE(Z,"^",4)=STATUS
SET $PIECE(Z,"^",5)=PATMTCH
SET $PIECE(Z,"^",6)=PROMTCH
SET $PIECE(Z,"^",7)=DRUMTCH
+28 IF FIELD="ID"
SET SORT=$SELECT(ERXID:1000000000000+ERXID,1:ERXID)_" "_ERXIEN
+29 IF FIELD="DR"
SET SORT=$$UP^XLFSTR(DRUG)_" "_ERXIEN
+30 IF FIELD="PR"
SET SORT=PROVIDER_" "_ERXIEN
+31 IF FIELD="RE"
SET SORT=MSGDTTM_" "_ERXIEN
+32 IF FIELD="STA"
SET SORT=STATUS_" "_RECDAT
+33 IF FIELD="PAM"
SET X=$PIECE(PATMTCH,"^")
SET SORT=$SELECT(X="":1,X="M":2,1:3)_ERXIEN
+34 IF FIELD="PRM"
SET X=$PIECE(PROMTCH,"^")
SET SORT=$SELECT(X="":1,X="M":2,1:3)_ERXIEN
+35 IF FIELD="DRM"
SET X=$PIECE(DRUMTCH,"^")
SET SORT=$SELECT(X="":1,X="M":2,1:3)_ERXIEN
+36 IF FIELD="ALL"
SET SORT=$$MATCHSRT^PSOERPT2($PIECE(PATMTCH,"^"),$PIECE(PROMTCH,"^"),$PIECE(DRUMTCH,"^"))_ERXIEN
+37 SET ^TMP("PSOERPTS",$JOB,CSGROUP,SORT)=Z
+38 SET ^TMP("PSOERPTS",$JOB,CSGROUP,SORT,"ERXIEN")=ERXIEN
+39 IF $PIECE(PATMTCH,"^",2)
SET ^TMP("PSOERPTS",$JOB,CSGROUP,SORT,"PATAM")=1
+40 IF $PIECE(PROMTCH,"^",2)
SET ^TMP("PSOERPTS",$JOB,CSGROUP,SORT,"PROAM")=1
+41 IF $PIECE(PROMTCH,"^",3)
SET ^TMP("PSOERPTS",$JOB,CSGROUP,SORT,"PROAV")=1
+42 IF $PIECE(DRUMTCH,"^",2)
SET ^TMP("PSOERPTS",$JOB,CSGROUP,SORT,"DRUAM")=1
+43 QUIT
+44 ;
MATCHSUG(ERXIEN,VIEW) ; Match Suggestion Prompt
+1 ; Input: ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
+2 ; (o)VIEW - View Only Mode (1:YES,0/null: NO)
+3 ;Output: VISTAPAT - VistA Patient (Pointer to #2) or 0 (Not selected or no suggestion on file)
+4 ;
+5 NEW MATCHSUG,MATCHCNT,LSTMTCH,LSTERXID,CNT,ERXPAT,VPAT,QUIT,DIR,DIRUT,DIROUT,X,Y,II
+6 SET ERXPAT=+$$GET1^DIQ(52.49,+$GET(ERXIEN),.04,"I")
IF 'ERXPAT
QUIT 0
+7 SET (MATCHSUG,MATCHCNT,CNT,VPAT,QUIT)=0
+8 FOR
SET VPAT=$ORDER(^PS(52.49,"APATVPAT",ERXPAT,VPAT))
if 'VPAT
QUIT
if '$$DEAD^PSONVARP(VPAT)
SET MATCHCNT=MATCHCNT+1
+9 IF MATCHCNT>3
SET MATCHCNT=3
+10 FOR
SET VPAT=$ORDER(^PS(52.49,"APATVPAT",ERXPAT,VPAT))
if 'VPAT
QUIT
Begin DoDot:1
+11 IF $$DEAD^PSONVARP(VPAT)
QUIT
+12 SET CNT=CNT+1
+13 SET LSTMTCH=$ORDER(^PS(52.49,"APATVPAT",ERXPAT,VPAT,9999999),-1)
IF 'LSTMTCH
QUIT
+14 SET LSTERXID=$ORDER(^PS(52.49,"APATVPAT",ERXPAT,VPAT,LSTMTCH,0))
IF 'LSTERXID!(LSTERXID=ERXIEN)
QUIT
+15 DO CMPPAT(ERXIEN,VPAT,LSTERXID,CNT_"^"_MATCHCNT)
+16 KILL DIR
SET DIR(0)="SOA^"_$SELECT('$GET(VIEW):"A:ACCEPT;",1:"")_$SELECT(MATCHCNT>1&(MATCHCNT'=CNT):"N:NEXT;",1:"")_"F:FORGET;E:EXIT"
+17 SET DIR("A")="ACTION on SUGGESTION: "_$SELECT('$GET(VIEW):"(A)CCEPT ",1:"")_$SELECT(MATCHCNT>1&(MATCHCNT'=CNT):"(N)EXT ",1:"")_"(F)ORGET (E)XIT: "
+18 SET DIR("B")=$SELECT(MATCHCNT>1&(MATCHCNT'=CNT):"NEXT",1:"EXIT")
+19 SET II=0
+20 IF '$GET(VIEW)
Begin DoDot:2
+21 SET II=II+1
SET DIR("?",II)=" ACCEPT - Accepts the suggested VistA Patient and matches it to the eRx"
End DoDot:2
+22 IF MATCHCNT>1&(MATCHCNT'=CNT)
Begin DoDot:2
+23 SET II=II+1
SET DIR("?",II)=" NEXT - Ignores this suggested VistA Patient and view the next one"
End DoDot:2
+24 SET II=II+1
SET DIR("?",II)=" FORGET - Forgets this suggested VistA Patient so that it is not presented"
+25 SET II=II+1
SET DIR("?",II)=" again in the future to any user"
+26 SET DIR("?")=" EXIT - Exit and proceed to match the VistA Patient manually"
+27 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)!(Y="E")
SET QUIT=1
QUIT
+28 IF Y="A"
SET MATCHSUG=VPAT
QUIT
+29 IF Y="N"
WRITE !
QUIT
+30 IF Y="F"
Begin DoDot:2
+31 KILL DIR
SET DIR(0)="SA^Y:YES;N:NO"
SET DIR("B")="NO"
+32 SET DIR("A")="Are you sure this validated match should be forgotten? "
+33 SET DIR("?")="This VistA Patient was previously matched and validated as a valid match for this eRx Patient. Once you forget this match it will no longer be suggested as a match for this eRx patient."
+34 WRITE !
DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)!(Y="N")
SET VPAT=VPAT-1
SET CNT=CNT-1
WRITE !
QUIT
+35 WRITE !?50,"Forgetting..."
KILL ^PS(52.49,"APATVPAT",ERXPAT,VPAT)
HANG 1
WRITE "done."
WRITE !
QUIT
End DoDot:2
End DoDot:1
IF MATCHSUG!(CNT>2)!QUIT
QUIT
+36 QUIT MATCHSUG
+37 ;
CMPPAT(ERXIEN,VISTAPAT,LSTERXID,COUNTER) ; Display the Comparison Between eRx and VistA Patients
+1 ;Input: ERXIEN - Pointer to ERX HOLDING QUEUE file (#52.49)
+2 ; VISTAPAT - VistA Patient (Pointer to #2)
+3 ; (o)LSTERXID - Last eRx IEN with the Match (Pointer to #52.49)
+4 ; (o)COUNTER - P1: Entry # | P2: Number of Entries
+5 IF '$DATA(^PS(52.49,+$GET(ERXIEN),0))!'$DATA(^DPT(+$GET(VISTAPAT),0))
QUIT
+6 NEW X,XX,LINE
+7 IF $GET(LSTERXID)
Begin DoDot:1
+8 WRITE !?55,"|Sugg. "
WRITE $GET(IOINHI)_+$GET(COUNTER)_$GET(IOINORM)_" of "_$GET(IOINHI)_$PIECE($GET(COUNTER),"^",2)_$GET(IOINORM)
+9 WRITE " - ",$GET(IOINHI)_$$FMTE^XLFDT($$GET1^DIQ(52.49,LSTERXID,1.14,"I")\1,"2Z")_$GET(IOINORM),"|"
End DoDot:1
+10 WRITE !,$GET(IORVON)_"ERX PATIENT"_$GET(IORVOFF),?41,$GET(IORVON)_"VISTA PATIENT"_$GET(IORVOFF)
+11 IF $GET(LSTERXID)
WRITE ?55,"|From eRx#: "_$GET(IOINHI)_$$GET1^DIQ(52.49,LSTERXID,.01)_$GET(IOINORM),?79,"|"
+12 SET $PIECE(XX,"_",81)=""
WRITE !,XX
+13 DO SETPAT^PSOERUT0("RS",ERXIEN,VISTAPAT)
+14 QUIT
+15 ;
CSERXS() ; Returns whether there are CS eRx on the list or not
+1 NEW CSERXS,LINE,ERXIEN
+2 SET CSERXS=0
+3 SET LINE=0
FOR
SET LINE=$ORDER(^TMP("PSOERPT0",$JOB,LINE))
if 'LINE
QUIT
Begin DoDot:1
+4 SET SEQ=+$GET(^TMP("PSOERPT0",$JOB,LINE,0))
IF 'SEQ
QUIT
+5 SET ERXIEN=+$GET(^TMP("PSOERPT0",$JOB,SEQ,"ERXIEN"))
+6 ;DO NOT FILL record
+7 IF $$GET1^DIQ(52.49,+$GET(ERXIEN),10.5,"I")=2
QUIT
+8 IF $$GET1^DIQ(52.49,ERXIEN,95.1,"I")
SET CSERXS=1
End DoDot:1
IF CSERXS
QUIT
+9 QUIT CSERXS
+10 ;
VAPATIEN() ; Returns the VistA Patient IEN or 0 (No VistA Patient Selected) or -1 (Different VistA Patients Selected)
+1 NEW VAPATIEN,LINE,ERXIEN,DFN,SEQ
+2 SET VAPATIEN=""
+3 SET LINE=0
FOR
SET LINE=$ORDER(^TMP("PSOERPT0",$JOB,LINE))
if 'LINE
QUIT
Begin DoDot:1
+4 SET SEQ=+$GET(^TMP("PSOERPT0",$JOB,LINE,0))
IF 'SEQ
QUIT
+5 SET ERXIEN=+$GET(^TMP("PSOERPT0",$JOB,SEQ,"ERXIEN"))
+6 SET DFN=+$$GET1^DIQ(52.49,ERXIEN,.05,"I")
IF DFN
IF 'VAPATIEN
SET VAPATIEN=DFN
+7 IF DFN
IF DFN'=VAPATIEN
SET VAPATIEN=-1
End DoDot:1
IF VAPATIEN=-1
QUIT
+8 QUIT VAPATIEN
+9 ;
OPACCESS(OPTION,USER,LIST) ; Returns whether the current user has priviledge to Perform a given action on a list of entries
+1 ; Input: OPTION - Option to be checked
+2 ; USER - Pointer to NEW PERSON file (#200)
+3 ; LIST - List of eRX Records to be checked
+4 ;Output: 1 - User has access | 0 - User does not have access
+5 NEW OPACCESS,SEQ,ERXIEN,PSOIEN
+6 SET OPACCESS=1
+7 SET SEQ=0
FOR
SET SEQ=$ORDER(LIST(SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+8 SET ERXIEN=+LIST(SEQ)
+9 ;DO NOT FILL record
+10 IF $$GET1^DIQ(52.49,+$GET(ERXIEN),10.5,"I")=2
SET OPACCESS=0
+11 SET PSOIEN=ERXIEN
+12 SET OPACCESS=$$OPACCESS^PSOERXU7(OPTION,USER,ERXIEN)
End DoDot:1
IF 'OPACCESS
QUIT
+13 QUIT OPACCESS
+14 ;
ALRDYVAL() ; Returns whether at least one record from the list has already been validated
+1 NEW ALRDYVAL,LINE,ERXIEN,SEQ
+2 SET ALRDYVAL=0
+3 SET LINE=0
FOR
SET LINE=$ORDER(^TMP("PSOERPT0",$JOB,LINE))
if 'LINE
QUIT
Begin DoDot:1
+4 SET SEQ=+$GET(^TMP("PSOERPT0",$JOB,LINE,0))
IF 'SEQ
QUIT
+5 SET ERXIEN=+$GET(^TMP("PSOERPT0",$JOB,SEQ,"ERXIEN"))
+6 ;DO NOT FILL record
+7 IF $$GET1^DIQ(52.49,+$GET(ERXIEN),10.5,"I")=2
QUIT
+8 SET ALRDYVAL=+$$GET1^DIQ(52.49,ERXIEN,1.7,"I")
End DoDot:1
IF ALRDYVAL
QUIT
+9 QUIT ALRDYVAL
+10 ;
VIDEO() ; Changes the Video Attributes for the list
+1 NEW I,LN
+2 ; The command below is used to circumvent a bug with Reverse Video in ListMan
+3 ; (Related to Filtered BY line in the header)
+4 DO CNTRL^VALM10(1,1,79,IORVOFF,IOINORM)
+5 ;
+6 IF '$DATA(IORVOFF)!'$DATA(VALMEVL)
QUIT
+7 FOR I=0:1:LINE
DO CNTRL^VALM10(I,1,80,IOINORM,IOINORM)
+8 ; - Highlighting the PRESCRIPTION line if SIG is displayed
+9 FOR I=1:1:LINE
Begin DoDot:1
+10 IF $DATA(HIGHLN(I))
IF $DATA(UNDLN(I))
DO CNTRL^VALM10(I,1,80,IOUON_IOINHI,IOUOFF_IOINORM)
QUIT
+11 IF $DATA(HIGHLN(I))
DO CNTRL^VALM10(I,1,80,IOINHI,IOINORM)
+12 IF $DATA(UNDLN(I))
DO CNTRL^VALM10(I,1,80,IOUON,IOINORM)
End DoDot:1
+13 ; - Highlighting the group lines (order type and status)
+14 IF $DATA(GRPLN)
Begin DoDot:1
+15 SET LN=0
FOR I=1:1
SET LN=$ORDER(GRPLN(LN))
if 'LN
QUIT
Begin DoDot:2
+16 SET LBL=GRPLN(LN)
SET POS=41-($LENGTH(LBL)\2)
+17 DO CNTRL^VALM10(LN,1,POS-1,IOUON,IOINORM)
+18 DO CNTRL^VALM10(LN,POS,$LENGTH(LBL),IORVON,IORVOFF_IOINORM)
+19 DO CNTRL^VALM10(LN,POS+$LENGTH(LBL),81-POS-$LENGTH(LBL),IOUON,IOINORM)
End DoDot:2
End DoDot:1
+20 ; - Highlighting Auto To Manual Match
+21 SET LN=0
FOR I=1:1
SET LN=$ORDER(PTMTCHLN(LN))
if 'LN
QUIT
Begin DoDot:1
+22 DO CNTRL^VALM10(LN,72,1,IOINHI,IOINORM)
End DoDot:1
+23 SET LN=0
FOR I=1:1
SET LN=$ORDER(PRMTCHLN(LN))
if 'LN
QUIT
Begin DoDot:1
+24 DO CNTRL^VALM10(LN,75,1,IOINHI,IOINORM)
End DoDot:1
+25 SET LN=0
FOR I=1:1
SET LN=$ORDER(PRVALLN(LN))
if 'LN
QUIT
Begin DoDot:1
+26 DO CNTRL^VALM10(LN,76,1,IOINHI,IOINORM)
End DoDot:1
+27 SET LN=0
FOR I=1:1
SET LN=$ORDER(DRMTCHLN(LN))
if 'LN
QUIT
Begin DoDot:1
+28 DO CNTRL^VALM10(LN,78,1,IOINHI,IOINORM)
End DoDot:1
+29 QUIT
+30 ;
ERXLST(RANGE,ERXLST) ; Given a Range of List Item returns the list of eRx's in an Array
+1 ; Input: RANGE - User Selected Range (ex: '1-5'; '2,5,8,10'; '1-5,11-15', etc)
+2 ;Output: ERXLST - Array with the selected list of eRx IEN's (Pointer to #52.49) - ERXLST(ERXIEN)
+3 ;
+4 NEW L1,LINE,INVALID,SEG
+5 SET INVALID=0
KILL ERXLST
+6 FOR L1=1:1:$LENGTH(RANGE,",")
Begin DoDot:1
+7 SET SEG=$PIECE(RANGE,",",L1)
IF SEG=""
QUIT
+8 IF SEG["-"
Begin DoDot:2
+9 FOR LINE=+$PIECE(SEG,"-"):1:+$PIECE(SEG,"-",2)
Begin DoDot:3
+10 SET ERXIEN=+$GET(^TMP("PSOERPT0",$JOB,LINE,"ERXIEN"))
IF 'ERXIEN
SET INVALID=1
QUIT
+11 SET ERXLST(LINE)=ERXIEN
End DoDot:3
End DoDot:2
+12 IF '$TEST
Begin DoDot:2
+13 SET ERXIEN=+$GET(^TMP("PSOERPT0",$JOB,+SEG,"ERXIEN"))
IF 'ERXIEN
SET INVALID=1
QUIT
+14 SET ERXLST(+SEG)=ERXIEN
End DoDot:2
End DoDot:1
+15 if INVALID
KILL ERXLST
+16 QUIT
+17 ;
LSTERXS(ERXLST,ISSONLY,DISPSEQ) ; Given a list of eRx IENs (array passed in by Reference) it displays a list
+1 ;Input: (r) ERXLST - Array with the list of eRx IEN's to be listed(Pointer to #52.49) - ERXLST(ERXIEN)
+2 ; (o) ISSONLY - List Entries with Issues Only? (1: YES | 0: NO)
+3 ; (o) DISPSEQ - Display the Sequence #? (1: YES | 0: NO)
+4 NEW SEQ,ERXIEN,HDR,XX,CNT,DIR
+5 SET HDR=$SELECT(DISPSEQ:"#",1:"")
SET $EXTRACT(HDR,$SELECT(DISPSEQ:5,1:1))="ERX ID"
SET $EXTRACT(HDR,17)="DRUG NAME"
SET $EXTRACT(HDR,52)="PROVIDER"
SET $EXTRACT(HDR,75)="STS"
+6 SET $PIECE(XX,"-",80)=""
WRITE !,HDR,!,XX
+7 SET (SEQ,CNT)=0
FOR
SET SEQ=$ORDER(ERXLST(SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+8 SET ERXIEN=+ERXLST(SEQ)
+9 IF $GET(ISSONLY)
IF $PIECE($GET(ERXLST(SEQ)),"^",2)=""
QUIT
+10 WRITE !,$SELECT(DISPSEQ:SEQ_$SELECT($$GET1^DIQ(52.49,ERXIEN,95.1,"I"):"]",1:"."),1:""),?$SELECT(DISPSEQ:4,1:0),$$GET1^DIQ(52.49,ERXIEN,.01)
+11 WRITE ?16,$EXTRACT($SELECT($$GETDRUG^PSOERXU5(ERXIEN)'="":$$GETDRUG^PSOERXU5(ERXIEN),1:"N/A"),1,34)
+12 WRITE ?51,$EXTRACT($$GET1^DIQ(52.49,ERXIEN,2.1),1,22)
+13 WRITE ?74,$$GET1^DIQ(52.49,ERXIEN,1)
+14 IF $PIECE($GET(ERXLST(SEQ)),"^",2)'=""
Begin DoDot:2
+15 SET CNT=CNT+1
WRITE !,"REASON: ",$PIECE($GET(ERXLST(SEQ)),"^",2)
End DoDot:2
+16 SET CNT=CNT+1
IF '(CNT#18)
DO PAUSE^VALM1
WRITE !,HDR,!,XX
End DoDot:1
+17 QUIT
+18 ;
PATIDS ; Patient Lookup Identifiers Display (set on DIC("W"))
+1 NEW Z
+2 WRITE " ",$$FMTE^XLFDT($PIECE(^(0),U,3),"5Z")," ",$PIECE(^(0),U,9)
+3 SET Z=$GET(^(.11))
IF $PIECE(Z,U,4)'=""
WRITE " ",$PIECE(Z,U,4)
IF $PIECE(Z,U,5)
WRITE ",",$PIECE(^DIC(5,+$PIECE(Z,U,5),0),U,2)
+4 QUIT
