- PSO52API ;BHAM ISC/SAB - Encap II API to return Rx data ; Feb 17, 2023@08:16:38
- ;;7.0;OUTPATIENT PHARMACY;**213,229,252,387,386,566,441,712,744**;DEC 1997;Build 3
- ; Reference to ^PS(55 in ICR #2228
- ;
- RX(DFN,LIST,IEN,RX,NODE,SDATE,EDATE) ;
- ;DFN: IEN from the PATIENT file (#2) [REQUIRED]
- ;LIST: Subscript name used in ^TMP global [REQUIRED]
- ;IEN: Internal prescription number [optional]
- ;RX#: RX # field (#.01) of the PRESCRIPTION file (#52) [optional]
- ;NODE: Determines data elements returned [optional]
- ;SDATE: Start Date [optional]
- ;EDATE: End Date [optional]
- ;
- Q:'$G(DFN) Q:$G(LIST)=""
- N DA,DR,PST,DIC,DIQ,ND,LK,DTE,DAT,I,X,D0 K ^TMP($J,LIST) S ^TMP($J,LIST,DFN,0)=0
- I $G(IEN) D PROCESS G CLEAN
- I $G(RX)]"",'$G(IEN) S IEN=$O(^PSRX("B",RX,0)) D G CLEAN
- .I 'IEN S ^TMP($J,LIST,DFN,0)="-1^NO DATA FOUND" Q
- .D PROCESS
- D DATE
- CLEAN F I=0:0 S I=$O(^TMP($J,LIST,DFN,I)) Q:'I S ^TMP($J,LIST,DFN,0)=^TMP($J,LIST,DFN,0)+1
- I ^TMP($J,LIST,DFN,0)=0 S ^TMP($J,LIST,DFN,0)="-1^NO DATA FOUND"
- K DA,DR,DIC,ND,DAT,PST,LK,DIQ,DTE,I,X
- Q
- PROCESS ;
- I DFN'=$P($G(^PSRX(IEN,0)),"^",2) S ^TMP($J,LIST,IEN,0)="-1^NO DATA FOUND (MISMATCHED PATIENT)" Q
- I $G(^PSRX(IEN,0))']"" S ^TMP($J,LIST,IEN,0)="-1^NO RX DATA FOUND" Q
- ;
- ; - Rx Auto Expiration
- N RXSTS,RXEXPDT
- S RXSTS=+$G(^PSRX(IEN,"STA")),RXEXPDT=$$GET1^DIQ(52,IEN,26,"I")
- I (RXSTS<11)!(RXSTS=16),(RXEXPDT<DT) D
- .S RXSTS=11 N DIE,DIC,DR,DA,STAT,PHARMST,COMM
- .S DIE=52,DA=IEN,DR="100////11" D ^DIE K DIE,DIC,DR
- .D ECAN^PSOUTL(IEN)
- .S STAT="SC",PHARMST="ZE",COMM="Medication Expired on "_$$FMTE^XLFDT(RXEXPDT,2)
- .D EN^PSOHLSN1(IEN,STAT,PHARMST,COMM)
- ;
- I $G(NODE)']"" D ZE,TW,TH,MI,ST,RF,CM,AT,LB,CPRS,PT^PSO52B,SD^PSO52B,TB^PSO52B,OI^PSO52B,MLT^PSO52B,IND S DAT="I" D IB Q
- D ST F LK=1:1:$L(NODE,",") S DAT=$P(NODE,",",LK),ND=$P(DAT,"^") D
- .I ND=0 D ZE Q
- .I ND=2 D ZE,TW Q
- .I ND=3 D TW,TH Q
- .I ND="R" D RF Q
- .I ND="I" D IB Q
- .I ND="P" D PT^PSO52B Q
- .I ND="O" D OI^PSO52B Q
- .I ND="T" D TB^PSO52B Q
- .I ND="L" D LB Q
- .I ND="S" D SD^PSO52B Q
- .I ND="M" D MI Q
- .I ND="C" D CM Q
- .I ND="A" D AT Q
- .I ND="ST" D ST Q
- .I ND="CPRS" D CPRS Q
- .I ND="ICD" D MLT^PSO52B Q
- .I ND="IND" D IND Q
- .S ^TMP($J,LIST,DFN,IEN,"INVALID REQUEST",ND)="Invalid Data Requested"
- Q
- ZE ;zero
- K PST S DIC=52,DA=IEN,DR=".01:9;10.3;10.6;11;14;16;17" D DIQ
- F DR=.01,1,2,3,4,5,6,6.5,7,8,9,10.3,10.6,11,14,16,17 D
- .I PST(52,DA,DR,"E")'=PST(52,DA,DR,"I") S ^TMP($J,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")_"^"_PST(52,DA,DR,"E") Q
- .S ^TMP($J,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")
- K DA,DR,PST,DIC,DIQ
- Q
- TW ;two
- Q:'$D(^PSRX(IEN,2))
- K PST S DIC=52,DA=IEN,DR="20:31;32.1;32.2;32.3;104" D DIQ
- F DR=20,21,22,23,24,25,26,27,28,29,30,31,32.1,32.2,32.3,104 D
- .I PST(52,DA,DR,"E")'=PST(52,DA,DR,"I") S ^TMP($J,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")_"^"_PST(52,DA,DR,"E") Q
- .S ^TMP($J,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")
- K DA,DR,PST,DIC,DIQ
- Q
- TH ;three
- Q:'$D(^PSRX(IEN,3))
- K PST S DIC=52,DA=IEN,DR="12;26.1;34.1;101;102;102.1;102.2;109;112" D DIQ
- F DR=12,26.1,34.1,101,102,102.1,102.2,109,112 D
- .I PST(52,DA,DR,"E")'=PST(52,DA,DR,"I") S ^TMP($J,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")_"^"_PST(52,DA,DR,"E") Q
- .S ^TMP($J,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")
- K DA,DR,PST,DIC,DIQ
- Q
- MI ;sig
- I $P($G(^PSRX(IEN,"SIG")),"^",2) D Q
- .I '$O(^PSRX(IEN,"SIG1",0)) S ^TMP($J,LIST,DFN,IEN,"M",0)="-1^NO DATA FOUND" Q
- .F I=0:0 S I=$O(^PSRX(IEN,"SIG1",I)) Q:'I S ^TMP($J,LIST,DFN,IEN,"M",I,0)=^PSRX(IEN,"SIG1",I,0),^TMP($J,LIST,DFN,IEN,"M",0)=$G(^TMP($J,LIST,DFN,IEN,"M",0))+1
- I $P($G(^PSRX(IEN,"SIG")),"^")']"" S ^TMP($J,LIST,DFN,IEN,"M",0)="-1^NO DATA FOUND" Q
- S X=$P($G(^PSRX(IEN,"SIG")),"^") D SIG^PSOHELP S ^TMP($J,LIST,DFN,IEN,"M",1,0)=$E(INS1,2,9999999),^TMP($J,LIST,DFN,IEN,"M",0)=1
- K X,INS1
- Q
- ST ;status
- I DT>$P(^PSRX(IEN,2),"^",6),$P(^PSRX(IEN,"STA"),"^")<11 D
- .N PSOEXRX,PSOEXSTA,ORN,PIFN,PSUSD,PRFDT,PDA,PSST
- .S PSOEXRX=IEN D EN2^PSOMAUEX K PSOEXRX,PSONM,PSONMX
- K PST S DIC=52,DA=IEN,DR=".01;100" D DIQ
- I PST(52,DA,100,"E")="DRUG INTERACTIONS" S PST(52,DA,100,"E")="NON-VERIFIED"
- S ^TMP($J,LIST,DFN,IEN,100)=PST(52,DA,100,"I")_"^"_PST(52,DA,100,"E")
- I PST(52,DA,100,"E")="ACTIVE",$G(^PSRX(DA,"PARK")),(LIST="OROCLST"!(LIST["MHV")!($E(LIST,1,4)="GMTS")) S ^TMP($J,LIST,DFN,IEN,100)=^TMP($J,LIST,DFN,IEN,100)_"/PARKED"
- S ^TMP($J,LIST,"B",PST(52,DA,.01,"E"),IEN)=""
- K DA,DR,PST,DIC,DIQ
- Q
- RF ;refill
- I '$O(^PSRX(IEN,1,0)) S ^TMP($J,LIST,DFN,IEN,"RF",0)="-1^NO DATA FOUND" Q
- I $P($G(DAT),"^",3) S DA(52.1)=$P(DAT,"^",3) D RFD K DA,DR,PST,DIC,DIQ Q
- F RF=0:0 S RF=$O(^PSRX(IEN,1,RF)) Q:'RF S DA(52.1)=RF D RFD
- K DA,DR,PST,DIC,DIQ,RF
- Q
- RFD K PST S DR(52.1)=".01:8;10.1;11;12;13;14;15;17;23",DIC=52,DA=IEN,DR=52 D DIQ
- I $P($G(DAT),"^",3),'$G(PST(52.1,DA(52.1),.01,"I")) S ^TMP($J,LIST,DFN,IEN,"RF",0)="-1^NO DATA FOUND" Q
- S ^TMP($J,LIST,DFN,IEN,"RF",0)=$G(^TMP($J,LIST,DFN,IEN,"RF",0))+1
- F DR=.01,1,1.1,1.2,2,3,4,5,6,7,8,10.1,11,12,13,14,15,17,23 D
- .I PST(52.1,DA(52.1),DR,"E")'=PST(52.1,DA(52.1),DR,"I") S ^TMP($J,LIST,DFN,IEN,"RF",DA(52.1),DR)=PST(52.1,DA(52.1),DR,"I")_"^"_PST(52.1,DA(52.1),DR,"E") Q
- .S ^TMP($J,LIST,DFN,IEN,"RF",DA(52.1),DR)=PST(52.1,DA(52.1),DR,"I")
- Q
- IB ;ib ori
- I $P($G(DAT),"^",2)="R" D IBR Q
- I $G(^PSRX(IEN,"IB"))']"" S ^TMP($J,LIST,DFN,IEN,"IB",0)="-1^NO DATA FOUND" Q
- K PST S DIC=52,DA=IEN,DR="105;106;106.5;106.6" D DIQ
- F DR=105,106,106.5,106.6 D
- .I PST(52,DA,DR,"E")'=PST(52,DA,DR,"I") S ^TMP($J,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")_"^"_PST(52,DA,DR,"E") Q
- .S ^TMP($J,LIST,DFN,IEN,DR)=PST(52,DA,DR,"E")
- K DA,DR,PST,DIC,DIQ
- I $P($G(DAT),"^",2)="" D IBR Q
- Q
- IBR ;ib ref
- I '$O(^PSRX(IEN,1,0)) S ^TMP($J,LIST,DFN,IEN,"IB",0)="-1^NO DATA FOUND" Q
- I $P($G(DAT),"^",2)="R",$P($G(DAT),"^",3) S DA(52.1)=$P(DAT,"^",3) D IBS K DA,DR,PST,DIC,DIQ Q
- N IB F IB=0:0 S IB=$O(^PSRX(IEN,1,IB)) Q:'IB S DA(52.1)=IB D IBS
- I '$G(^TMP($J,LIST,DFN,IEN,"IB",0)) K ^TMP($J,LIST,DFN,IEN,"IB") S ^TMP($J,LIST,DFN,IEN,"IB",0)="-1^NO DATA FOUND"
- K DA,DR,PST,DIC,DIQ,IB
- Q
- IBS I $P($G(DAT),"^",3),'$G(^PSRX(IEN,1,DA(52.1),"IB")) S ^TMP($J,LIST,DFN,IEN,"IB",0)="-1^NO DATA FOUND" Q
- I '$D(^PSRX(IEN,1,DA(52.1),"IB")) S ^TMP($J,LIST,DFN,IEN,"IB",DA(52.1),0)="-1^NO DATA FOUND" Q
- K PST S DR(52.1)="9;9.1",DIC=52,DA=IEN,DR=52 D DIQ
- S ^TMP($J,LIST,DFN,IEN,"IB",0)=$G(^TMP($J,LIST,DFN,IEN,"IB",0))+1
- F DR=9,9.1 D
- .I PST(52.1,DA(52.1),DR,"E")'=PST(52.1,DA(52.1),DR,"I") S ^TMP($J,LIST,DFN,IEN,"IB",DA(52.1),DR)=PST(52.1,DA(52.1),DR,"I")_"^"_PST(52.1,DA(52.1),DR,"E") Q
- .S ^TMP($J,LIST,DFN,IEN,"IB",DA(52.1),DR)=PST(52.1,DA(52.1),DR,"I")
- Q
- CM ;cmop
- I '$O(^PSRX(IEN,4,0)) S ^TMP($J,LIST,DFN,IEN,"C",0)="-1^NO DATA FOUND" Q
- N CM F CM=0:0 S CM=$O(^PSRX(IEN,4,CM)) Q:'CM S DA(52.01)=CM D CMP
- K DA,DR,PST,DIC,DIQ,CM
- Q
- CMP S ^TMP($J,LIST,DFN,IEN,"C",0)=$G(^TMP($J,LIST,DFN,IEN,"C",0))+1
- K PST S DR(52.01)=".01;2;3;4;9:12",DIC=52,DA=IEN,DR=400 D DIQ
- F DR=.01,2,3,4,9,10,11,12 D
- .I PST(52.01,DA(52.01),DR,"E")'=PST(52.01,DA(52.01),DR,"I") S ^TMP($J,LIST,DFN,IEN,"C",DA(52.01),DR)=PST(52.01,DA(52.01),DR,"I")_"^"_PST(52.01,DA(52.01),DR,"E") Q
- .S ^TMP($J,LIST,DFN,IEN,"C",DA(52.01),DR)=PST(52.01,DA(52.01),DR,"I")
- Q
- AT ;activity log
- I '$O(^PSRX(IEN,"A",0)) S ^TMP($J,LIST,DFN,IEN,"A",0)="-1^NO DATA FOUND" Q
- ;P744 Check for missing Activity Log Header node and fix
- I '$D(^PSRX(IEN,"A",0)) D
- . S COUNT="" S COUNT=$O(^PSRX(IEN,"A","Z"),-1)
- . S ^PSRX(IEN,"A",0)="^52.3DA^"_COUNT_"^"_COUNT
- N AT F AT=0:0 S AT=$O(^PSRX(IEN,"A",AT)) Q:'AT S DA(52.3)=AT D ATP
- K DA,DR,PST,DIC,DIQ,AT
- Q
- ATP K PST S DR(52.3)=".01;.02;.03;.04;.05" S DIC=52,DA=IEN,DR=40 D DIQ
- S ^TMP($J,LIST,DFN,IEN,"A",0)=$G(^TMP($J,LIST,DFN,IEN,"A",0))+1
- F DR=.01,.02,.03,.04,.05 D
- .I DR=.04 S ^TMP($J,LIST,DFN,IEN,"A",DA(52.3),DR)=PST(52.3,DA(52.3),DR,"E") Q
- .I PST(52.3,DA(52.3),DR,"E")'=PST(52.3,DA(52.3),DR,"I") S ^TMP($J,LIST,DFN,IEN,"A",DA(52.3),DR)=PST(52.3,DA(52.3),DR,"I")_"^"_PST(52.3,DA(52.3),DR,"E") Q
- .S ^TMP($J,LIST,DFN,IEN,"A",DA(52.3),DR)=PST(52.3,DA(52.3),DR,"I")
- I $O(^PSRX(IEN,"A",AT,2,0)) D OC
- Q
- OC ;Activity Log Other Comments
- N PSOOC,PSOOCD
- F PSOOC=0:0 S PSOOC=$O(^PSRX(IEN,"A",DA(52.3),2,PSOOC)) Q:'PSOOC D
- .S PSOOCD=$G(^PSRX(IEN,"A",DA(52.3),2,PSOOC,0)) I PSOOCD'="" S ^TMP($J,LIST,DFN,IEN,"A",DA(52.3),"OC",PSOOC,.01)=PSOOCD
- Q
- LB ;label log
- I '$O(^PSRX(IEN,"L",0)) S ^TMP($J,LIST,DFN,IEN,"L",0)="-1^NO DATA FOUND" Q
- N LB F LB=0:0 S LB=$O(^PSRX(IEN,"L",LB)) Q:'LB S DA(52.032)=LB D LBP
- K DA,DR,PST,DIC,DIQ,LB
- Q
- LBP S ^TMP($J,LIST,DFN,IEN,"L",0)=$G(^TMP($J,LIST,DFN,IEN,"L",0))+1
- K PST S DR(52.032)=".01;1;2;3;4" S DIC=52,DA=IEN,DR=32 D DIQ
- F DR=.01,1,2,3,4 D
- .I DR=1 S ^TMP($J,LIST,DFN,IEN,"L",DA(52.032),DR)=PST(52.032,DA(52.032),DR,"E") Q
- .I PST(52.032,DA(52.032),DR,"E")'=PST(52.032,DA(52.032),DR,"I") S ^TMP($J,LIST,DFN,IEN,"L",DA(52.032),DR)=PST(52.032,DA(52.032),DR,"I")_"^"_PST(52.032,DA(52.032),DR,"E") Q
- .S ^TMP($J,LIST,DFN,IEN,"L",DA(52.032),DR)=PST(52.032,DA(52.032),DR,"I")
- K DA,DR,PST,DIC,DIQ
- Q
- CPRS ;CPRS number
- K PST S DIC=52,DA=IEN,DR=39.3 D DIQ
- I $G(PST(52,DA,DR,"E"))']"" S ^TMP($J,LIST,DFN,DA,DR)="" Q
- I PST(52,DA,DR,"E")'=PST(52,DA,DR,"I") S ^TMP($J,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")_"^"_PST(52,DA,DR,"E") Q
- S ^TMP($J,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")
- K DA,DR,PST,DIC,DIQ
- Q
- DATE ;date range
- I $G(SDATE) S DTE=SDATE-1 D Q
- .I $G(EDATE) D Q
- ..F S DTE=$O(^PS(55,DFN,"P","A",DTE)) Q:'DTE!(DTE>EDATE) F IEN=0:0 S IEN=$O(^PS(55,DFN,"P","A",DTE,IEN)) Q:'IEN D:$P($G(^PSRX(IEN,"STA")),"^")'=13 PROCESS
- .F S DTE=$O(^PS(55,DFN,"P","A",DTE)) Q:'DTE F IEN=0:0 S IEN=$O(^PS(55,DFN,"P","A",DTE,IEN)) Q:'IEN D:$P($G(^PSRX(IEN,"STA")),"^")'=13 PROCESS
- I $G(EDATE),'$G(SDATE) S DTE=DT-1 D Q
- .F S DTE=$O(^PS(55,DFN,"P","A",DTE)) Q:'DTE!(DTE>EDATE) F IEN=0:0 S IEN=$O(^PS(55,DFN,"P","A",DTE,IEN)) Q:'IEN D:$P($G(^PSRX(IEN,"STA")),"^")'=13 PROCESS
- S DTE=DT-1 F S DTE=$O(^PS(55,DFN,"P","A",DTE)) Q:'DTE F IEN=0:0 S IEN=$O(^PS(55,DFN,"P","A",DTE,IEN)) Q:'IEN D:$P($G(^PSRX(IEN,"STA")),"^")'=13 PROCESS
- Q
- PROF(DFN,LIST,SDATE,EDATE) ;
- D ^PSO52AP1
- Q
- IND ;Indication
- S:$P($G(^PSRX(IEN,"IND")),U)]"" ^TMP($J,LIST,DFN,IEN,"IND")=$P($G(^PSRX(IEN,"IND")),U,1,2)
- Q
- DIQ ;process fields
- S DIQ="PST",DIQ(0)="IE" D EN^DIQ1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSO52API 10329 printed Jan 18, 2025@03:24:18 Page 2
- PSO52API ;BHAM ISC/SAB - Encap II API to return Rx data ; Feb 17, 2023@08:16:38
- +1 ;;7.0;OUTPATIENT PHARMACY;**213,229,252,387,386,566,441,712,744**;DEC 1997;Build 3
- +2 ; Reference to ^PS(55 in ICR #2228
- +3 ;
- RX(DFN,LIST,IEN,RX,NODE,SDATE,EDATE) ;
- +1 ;DFN: IEN from the PATIENT file (#2) [REQUIRED]
- +2 ;LIST: Subscript name used in ^TMP global [REQUIRED]
- +3 ;IEN: Internal prescription number [optional]
- +4 ;RX#: RX # field (#.01) of the PRESCRIPTION file (#52) [optional]
- +5 ;NODE: Determines data elements returned [optional]
- +6 ;SDATE: Start Date [optional]
- +7 ;EDATE: End Date [optional]
- +8 ;
- +9 if '$GET(DFN)
- QUIT
- if $GET(LIST)=""
- QUIT
- +10 NEW DA,DR,PST,DIC,DIQ,ND,LK,DTE,DAT,I,X,D0
- KILL ^TMP($JOB,LIST)
- SET ^TMP($JOB,LIST,DFN,0)=0
- +11 IF $GET(IEN)
- DO PROCESS
- GOTO CLEAN
- +12 IF $GET(RX)]""
- IF '$GET(IEN)
- SET IEN=$ORDER(^PSRX("B",RX,0))
- Begin DoDot:1
- +13 IF 'IEN
- SET ^TMP($JOB,LIST,DFN,0)="-1^NO DATA FOUND"
- QUIT
- +14 DO PROCESS
- End DoDot:1
- GOTO CLEAN
- +15 DO DATE
- CLEAN FOR I=0:0
- SET I=$ORDER(^TMP($JOB,LIST,DFN,I))
- if 'I
- QUIT
- SET ^TMP($JOB,LIST,DFN,0)=^TMP($JOB,LIST,DFN,0)+1
- +1 IF ^TMP($JOB,LIST,DFN,0)=0
- SET ^TMP($JOB,LIST,DFN,0)="-1^NO DATA FOUND"
- +2 KILL DA,DR,DIC,ND,DAT,PST,LK,DIQ,DTE,I,X
- +3 QUIT
- PROCESS ;
- +1 IF DFN'=$PIECE($GET(^PSRX(IEN,0)),"^",2)
- SET ^TMP($JOB,LIST,IEN,0)="-1^NO DATA FOUND (MISMATCHED PATIENT)"
- QUIT
- +2 IF $GET(^PSRX(IEN,0))']""
- SET ^TMP($JOB,LIST,IEN,0)="-1^NO RX DATA FOUND"
- QUIT
- +3 ;
- +4 ; - Rx Auto Expiration
- +5 NEW RXSTS,RXEXPDT
- +6 SET RXSTS=+$GET(^PSRX(IEN,"STA"))
- SET RXEXPDT=$$GET1^DIQ(52,IEN,26,"I")
- +7 IF (RXSTS<11)!(RXSTS=16)
- IF (RXEXPDT<DT)
- Begin DoDot:1
- +8 SET RXSTS=11
- NEW DIE,DIC,DR,DA,STAT,PHARMST,COMM
- +9 SET DIE=52
- SET DA=IEN
- SET DR="100////11"
- DO ^DIE
- KILL DIE,DIC,DR
- +10 DO ECAN^PSOUTL(IEN)
- +11 SET STAT="SC"
- SET PHARMST="ZE"
- SET COMM="Medication Expired on "_$$FMTE^XLFDT(RXEXPDT,2)
- +12 DO EN^PSOHLSN1(IEN,STAT,PHARMST,COMM)
- End DoDot:1
- +13 ;
- +14 IF $GET(NODE)']""
- DO ZE
- DO TW
- DO TH
- DO MI
- DO ST
- DO RF
- DO CM
- DO AT
- DO LB
- DO CPRS
- DO PT^PSO52B
- DO SD^PSO52B
- DO TB^PSO52B
- DO OI^PSO52B
- DO MLT^PSO52B
- DO IND
- SET DAT="I"
- DO IB
- QUIT
- +15 DO ST
- FOR LK=1:1:$LENGTH(NODE,",")
- SET DAT=$PIECE(NODE,",",LK)
- SET ND=$PIECE(DAT,"^")
- Begin DoDot:1
- +16 IF ND=0
- DO ZE
- QUIT
- +17 IF ND=2
- DO ZE
- DO TW
- QUIT
- +18 IF ND=3
- DO TW
- DO TH
- QUIT
- +19 IF ND="R"
- DO RF
- QUIT
- +20 IF ND="I"
- DO IB
- QUIT
- +21 IF ND="P"
- DO PT^PSO52B
- QUIT
- +22 IF ND="O"
- DO OI^PSO52B
- QUIT
- +23 IF ND="T"
- DO TB^PSO52B
- QUIT
- +24 IF ND="L"
- DO LB
- QUIT
- +25 IF ND="S"
- DO SD^PSO52B
- QUIT
- +26 IF ND="M"
- DO MI
- QUIT
- +27 IF ND="C"
- DO CM
- QUIT
- +28 IF ND="A"
- DO AT
- QUIT
- +29 IF ND="ST"
- DO ST
- QUIT
- +30 IF ND="CPRS"
- DO CPRS
- QUIT
- +31 IF ND="ICD"
- DO MLT^PSO52B
- QUIT
- +32 IF ND="IND"
- DO IND
- QUIT
- +33 SET ^TMP($JOB,LIST,DFN,IEN,"INVALID REQUEST",ND)="Invalid Data Requested"
- End DoDot:1
- +34 QUIT
- ZE ;zero
- +1 KILL PST
- SET DIC=52
- SET DA=IEN
- SET DR=".01:9;10.3;10.6;11;14;16;17"
- DO DIQ
- +2 FOR DR=.01,1,2,3,4,5,6,6.5,7,8,9,10.3,10.6,11,14,16,17
- Begin DoDot:1
- +3 IF PST(52,DA,DR,"E")'=PST(52,DA,DR,"I")
- SET ^TMP($JOB,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")_"^"_PST(52,DA,DR,"E")
- QUIT
- +4 SET ^TMP($JOB,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")
- End DoDot:1
- +5 KILL DA,DR,PST,DIC,DIQ
- +6 QUIT
- TW ;two
- +1 if '$DATA(^PSRX(IEN,2))
- QUIT
- +2 KILL PST
- SET DIC=52
- SET DA=IEN
- SET DR="20:31;32.1;32.2;32.3;104"
- DO DIQ
- +3 FOR DR=20,21,22,23,24,25,26,27,28,29,30,31,32.1,32.2,32.3,104
- Begin DoDot:1
- +4 IF PST(52,DA,DR,"E")'=PST(52,DA,DR,"I")
- SET ^TMP($JOB,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")_"^"_PST(52,DA,DR,"E")
- QUIT
- +5 SET ^TMP($JOB,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")
- End DoDot:1
- +6 KILL DA,DR,PST,DIC,DIQ
- +7 QUIT
- TH ;three
- +1 if '$DATA(^PSRX(IEN,3))
- QUIT
- +2 KILL PST
- SET DIC=52
- SET DA=IEN
- SET DR="12;26.1;34.1;101;102;102.1;102.2;109;112"
- DO DIQ
- +3 FOR DR=12,26.1,34.1,101,102,102.1,102.2,109,112
- Begin DoDot:1
- +4 IF PST(52,DA,DR,"E")'=PST(52,DA,DR,"I")
- SET ^TMP($JOB,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")_"^"_PST(52,DA,DR,"E")
- QUIT
- +5 SET ^TMP($JOB,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")
- End DoDot:1
- +6 KILL DA,DR,PST,DIC,DIQ
- +7 QUIT
- MI ;sig
- +1 IF $PIECE($GET(^PSRX(IEN,"SIG")),"^",2)
- Begin DoDot:1
- +2 IF '$ORDER(^PSRX(IEN,"SIG1",0))
- SET ^TMP($JOB,LIST,DFN,IEN,"M",0)="-1^NO DATA FOUND"
- QUIT
- +3 FOR I=0:0
- SET I=$ORDER(^PSRX(IEN,"SIG1",I))
- if 'I
- QUIT
- SET ^TMP($JOB,LIST,DFN,IEN,"M",I,0)=^PSRX(IEN,"SIG1",I,0)
- SET ^TMP($JOB,LIST,DFN,IEN,"M",0)=$GET(^TMP($JOB,LIST,DFN,IEN,"M",0))+1
- End DoDot:1
- QUIT
- +4 IF $PIECE($GET(^PSRX(IEN,"SIG")),"^")']""
- SET ^TMP($JOB,LIST,DFN,IEN,"M",0)="-1^NO DATA FOUND"
- QUIT
- +5 SET X=$PIECE($GET(^PSRX(IEN,"SIG")),"^")
- DO SIG^PSOHELP
- SET ^TMP($JOB,LIST,DFN,IEN,"M",1,0)=$EXTRACT(INS1,2,9999999)
- SET ^TMP($JOB,LIST,DFN,IEN,"M",0)=1
- +6 KILL X,INS1
- +7 QUIT
- ST ;status
- +1 IF DT>$PIECE(^PSRX(IEN,2),"^",6)
- IF $PIECE(^PSRX(IEN,"STA"),"^")<11
- Begin DoDot:1
- +2 NEW PSOEXRX,PSOEXSTA,ORN,PIFN,PSUSD,PRFDT,PDA,PSST
- +3 SET PSOEXRX=IEN
- DO EN2^PSOMAUEX
- KILL PSOEXRX,PSONM,PSONMX
- End DoDot:1
- +4 KILL PST
- SET DIC=52
- SET DA=IEN
- SET DR=".01;100"
- DO DIQ
- +5 IF PST(52,DA,100,"E")="DRUG INTERACTIONS"
- SET PST(52,DA,100,"E")="NON-VERIFIED"
- +6 SET ^TMP($JOB,LIST,DFN,IEN,100)=PST(52,DA,100,"I")_"^"_PST(52,DA,100,"E")
- +7 IF PST(52,DA,100,"E")="ACTIVE"
- IF $GET(^PSRX(DA,"PARK"))
- IF (LIST="OROCLST"!(LIST["MHV")!($EXTRACT(LIST,1,4)="GMTS"))
- SET ^TMP($JOB,LIST,DFN,IEN,100)=^TMP($JOB,LIST,DFN,IEN,100)_"/PARKED"
- +8 SET ^TMP($JOB,LIST,"B",PST(52,DA,.01,"E"),IEN)=""
- +9 KILL DA,DR,PST,DIC,DIQ
- +10 QUIT
- RF ;refill
- +1 IF '$ORDER(^PSRX(IEN,1,0))
- SET ^TMP($JOB,LIST,DFN,IEN,"RF",0)="-1^NO DATA FOUND"
- QUIT
- +2 IF $PIECE($GET(DAT),"^",3)
- SET DA(52.1)=$PIECE(DAT,"^",3)
- DO RFD
- KILL DA,DR,PST,DIC,DIQ
- QUIT
- +3 FOR RF=0:0
- SET RF=$ORDER(^PSRX(IEN,1,RF))
- if 'RF
- QUIT
- SET DA(52.1)=RF
- DO RFD
- +4 KILL DA,DR,PST,DIC,DIQ,RF
- +5 QUIT
- RFD KILL PST
- SET DR(52.1)=".01:8;10.1;11;12;13;14;15;17;23"
- SET DIC=52
- SET DA=IEN
- SET DR=52
- DO DIQ
- +1 IF $PIECE($GET(DAT),"^",3)
- IF '$GET(PST(52.1,DA(52.1),.01,"I"))
- SET ^TMP($JOB,LIST,DFN,IEN,"RF",0)="-1^NO DATA FOUND"
- QUIT
- +2 SET ^TMP($JOB,LIST,DFN,IEN,"RF",0)=$GET(^TMP($JOB,LIST,DFN,IEN,"RF",0))+1
- +3 FOR DR=.01,1,1.1,1.2,2,3,4,5,6,7,8,10.1,11,12,13,14,15,17,23
- Begin DoDot:1
- +4 IF PST(52.1,DA(52.1),DR,"E")'=PST(52.1,DA(52.1),DR,"I")
- SET ^TMP($JOB,LIST,DFN,IEN,"RF",DA(52.1),DR)=PST(52.1,DA(52.1),DR,"I")_"^"_PST(52.1,DA(52.1),DR,"E")
- QUIT
- +5 SET ^TMP($JOB,LIST,DFN,IEN,"RF",DA(52.1),DR)=PST(52.1,DA(52.1),DR,"I")
- End DoDot:1
- +6 QUIT
- IB ;ib ori
- +1 IF $PIECE($GET(DAT),"^",2)="R"
- DO IBR
- QUIT
- +2 IF $GET(^PSRX(IEN,"IB"))']""
- SET ^TMP($JOB,LIST,DFN,IEN,"IB",0)="-1^NO DATA FOUND"
- QUIT
- +3 KILL PST
- SET DIC=52
- SET DA=IEN
- SET DR="105;106;106.5;106.6"
- DO DIQ
- +4 FOR DR=105,106,106.5,106.6
- Begin DoDot:1
- +5 IF PST(52,DA,DR,"E")'=PST(52,DA,DR,"I")
- SET ^TMP($JOB,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")_"^"_PST(52,DA,DR,"E")
- QUIT
- +6 SET ^TMP($JOB,LIST,DFN,IEN,DR)=PST(52,DA,DR,"E")
- End DoDot:1
- +7 KILL DA,DR,PST,DIC,DIQ
- +8 IF $PIECE($GET(DAT),"^",2)=""
- DO IBR
- QUIT
- +9 QUIT
- IBR ;ib ref
- +1 IF '$ORDER(^PSRX(IEN,1,0))
- SET ^TMP($JOB,LIST,DFN,IEN,"IB",0)="-1^NO DATA FOUND"
- QUIT
- +2 IF $PIECE($GET(DAT),"^",2)="R"
- IF $PIECE($GET(DAT),"^",3)
- SET DA(52.1)=$PIECE(DAT,"^",3)
- DO IBS
- KILL DA,DR,PST,DIC,DIQ
- QUIT
- +3 NEW IB
- FOR IB=0:0
- SET IB=$ORDER(^PSRX(IEN,1,IB))
- if 'IB
- QUIT
- SET DA(52.1)=IB
- DO IBS
- +4 IF '$GET(^TMP($JOB,LIST,DFN,IEN,"IB",0))
- KILL ^TMP($JOB,LIST,DFN,IEN,"IB")
- SET ^TMP($JOB,LIST,DFN,IEN,"IB",0)="-1^NO DATA FOUND"
- +5 KILL DA,DR,PST,DIC,DIQ,IB
- +6 QUIT
- IBS IF $PIECE($GET(DAT),"^",3)
- IF '$GET(^PSRX(IEN,1,DA(52.1),"IB"))
- SET ^TMP($JOB,LIST,DFN,IEN,"IB",0)="-1^NO DATA FOUND"
- QUIT
- +1 IF '$DATA(^PSRX(IEN,1,DA(52.1),"IB"))
- SET ^TMP($JOB,LIST,DFN,IEN,"IB",DA(52.1),0)="-1^NO DATA FOUND"
- QUIT
- +2 KILL PST
- SET DR(52.1)="9;9.1"
- SET DIC=52
- SET DA=IEN
- SET DR=52
- DO DIQ
- +3 SET ^TMP($JOB,LIST,DFN,IEN,"IB",0)=$GET(^TMP($JOB,LIST,DFN,IEN,"IB",0))+1
- +4 FOR DR=9,9.1
- Begin DoDot:1
- +5 IF PST(52.1,DA(52.1),DR,"E")'=PST(52.1,DA(52.1),DR,"I")
- SET ^TMP($JOB,LIST,DFN,IEN,"IB",DA(52.1),DR)=PST(52.1,DA(52.1),DR,"I")_"^"_PST(52.1,DA(52.1),DR,"E")
- QUIT
- +6 SET ^TMP($JOB,LIST,DFN,IEN,"IB",DA(52.1),DR)=PST(52.1,DA(52.1),DR,"I")
- End DoDot:1
- +7 QUIT
- CM ;cmop
- +1 IF '$ORDER(^PSRX(IEN,4,0))
- SET ^TMP($JOB,LIST,DFN,IEN,"C",0)="-1^NO DATA FOUND"
- QUIT
- +2 NEW CM
- FOR CM=0:0
- SET CM=$ORDER(^PSRX(IEN,4,CM))
- if 'CM
- QUIT
- SET DA(52.01)=CM
- DO CMP
- +3 KILL DA,DR,PST,DIC,DIQ,CM
- +4 QUIT
- CMP SET ^TMP($JOB,LIST,DFN,IEN,"C",0)=$GET(^TMP($JOB,LIST,DFN,IEN,"C",0))+1
- +1 KILL PST
- SET DR(52.01)=".01;2;3;4;9:12"
- SET DIC=52
- SET DA=IEN
- SET DR=400
- DO DIQ
- +2 FOR DR=.01,2,3,4,9,10,11,12
- Begin DoDot:1
- +3 IF PST(52.01,DA(52.01),DR,"E")'=PST(52.01,DA(52.01),DR,"I")
- SET ^TMP($JOB,LIST,DFN,IEN,"C",DA(52.01),DR)=PST(52.01,DA(52.01),DR,"I")_"^"_PST(52.01,DA(52.01),DR,"E")
- QUIT
- +4 SET ^TMP($JOB,LIST,DFN,IEN,"C",DA(52.01),DR)=PST(52.01,DA(52.01),DR,"I")
- End DoDot:1
- +5 QUIT
- AT ;activity log
- +1 IF '$ORDER(^PSRX(IEN,"A",0))
- SET ^TMP($JOB,LIST,DFN,IEN,"A",0)="-1^NO DATA FOUND"
- QUIT
- +2 ;P744 Check for missing Activity Log Header node and fix
- +3 IF '$DATA(^PSRX(IEN,"A",0))
- Begin DoDot:1
- +4 SET COUNT=""
- SET COUNT=$ORDER(^PSRX(IEN,"A","Z"),-1)
- +5 SET ^PSRX(IEN,"A",0)="^52.3DA^"_COUNT_"^"_COUNT
- End DoDot:1
- +6 NEW AT
- FOR AT=0:0
- SET AT=$ORDER(^PSRX(IEN,"A",AT))
- if 'AT
- QUIT
- SET DA(52.3)=AT
- DO ATP
- +7 KILL DA,DR,PST,DIC,DIQ,AT
- +8 QUIT
- ATP KILL PST
- SET DR(52.3)=".01;.02;.03;.04;.05"
- SET DIC=52
- SET DA=IEN
- SET DR=40
- DO DIQ
- +1 SET ^TMP($JOB,LIST,DFN,IEN,"A",0)=$GET(^TMP($JOB,LIST,DFN,IEN,"A",0))+1
- +2 FOR DR=.01,.02,.03,.04,.05
- Begin DoDot:1
- +3 IF DR=.04
- SET ^TMP($JOB,LIST,DFN,IEN,"A",DA(52.3),DR)=PST(52.3,DA(52.3),DR,"E")
- QUIT
- +4 IF PST(52.3,DA(52.3),DR,"E")'=PST(52.3,DA(52.3),DR,"I")
- SET ^TMP($JOB,LIST,DFN,IEN,"A",DA(52.3),DR)=PST(52.3,DA(52.3),DR,"I")_"^"_PST(52.3,DA(52.3),DR,"E")
- QUIT
- +5 SET ^TMP($JOB,LIST,DFN,IEN,"A",DA(52.3),DR)=PST(52.3,DA(52.3),DR,"I")
- End DoDot:1
- +6 IF $ORDER(^PSRX(IEN,"A",AT,2,0))
- DO OC
- +7 QUIT
- OC ;Activity Log Other Comments
- +1 NEW PSOOC,PSOOCD
- +2 FOR PSOOC=0:0
- SET PSOOC=$ORDER(^PSRX(IEN,"A",DA(52.3),2,PSOOC))
- if 'PSOOC
- QUIT
- Begin DoDot:1
- +3 SET PSOOCD=$GET(^PSRX(IEN,"A",DA(52.3),2,PSOOC,0))
- IF PSOOCD'=""
- SET ^TMP($JOB,LIST,DFN,IEN,"A",DA(52.3),"OC",PSOOC,.01)=PSOOCD
- End DoDot:1
- +4 QUIT
- LB ;label log
- +1 IF '$ORDER(^PSRX(IEN,"L",0))
- SET ^TMP($JOB,LIST,DFN,IEN,"L",0)="-1^NO DATA FOUND"
- QUIT
- +2 NEW LB
- FOR LB=0:0
- SET LB=$ORDER(^PSRX(IEN,"L",LB))
- if 'LB
- QUIT
- SET DA(52.032)=LB
- DO LBP
- +3 KILL DA,DR,PST,DIC,DIQ,LB
- +4 QUIT
- LBP SET ^TMP($JOB,LIST,DFN,IEN,"L",0)=$GET(^TMP($JOB,LIST,DFN,IEN,"L",0))+1
- +1 KILL PST
- SET DR(52.032)=".01;1;2;3;4"
- SET DIC=52
- SET DA=IEN
- SET DR=32
- DO DIQ
- +2 FOR DR=.01,1,2,3,4
- Begin DoDot:1
- +3 IF DR=1
- SET ^TMP($JOB,LIST,DFN,IEN,"L",DA(52.032),DR)=PST(52.032,DA(52.032),DR,"E")
- QUIT
- +4 IF PST(52.032,DA(52.032),DR,"E")'=PST(52.032,DA(52.032),DR,"I")
- SET ^TMP($JOB,LIST,DFN,IEN,"L",DA(52.032),DR)=PST(52.032,DA(52.032),DR,"I")_"^"_PST(52.032,DA(52.032),DR,"E")
- QUIT
- +5 SET ^TMP($JOB,LIST,DFN,IEN,"L",DA(52.032),DR)=PST(52.032,DA(52.032),DR,"I")
- End DoDot:1
- +6 KILL DA,DR,PST,DIC,DIQ
- +7 QUIT
- CPRS ;CPRS number
- +1 KILL PST
- SET DIC=52
- SET DA=IEN
- SET DR=39.3
- DO DIQ
- +2 IF $GET(PST(52,DA,DR,"E"))']""
- SET ^TMP($JOB,LIST,DFN,DA,DR)=""
- QUIT
- +3 IF PST(52,DA,DR,"E")'=PST(52,DA,DR,"I")
- SET ^TMP($JOB,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")_"^"_PST(52,DA,DR,"E")
- QUIT
- +4 SET ^TMP($JOB,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")
- +5 KILL DA,DR,PST,DIC,DIQ
- +6 QUIT
- DATE ;date range
- +1 IF $GET(SDATE)
- SET DTE=SDATE-1
- Begin DoDot:1
- +2 IF $GET(EDATE)
- Begin DoDot:2
- +3 FOR
- SET DTE=$ORDER(^PS(55,DFN,"P","A",DTE))
- if 'DTE!(DTE>EDATE)
- QUIT
- FOR IEN=0:0
- SET IEN=$ORDER(^PS(55,DFN,"P","A",DTE,IEN))
- if 'IEN
- QUIT
- if $PIECE($GET(^PSRX(IEN,"STA")),"^")'=13
- DO PROCESS
- End DoDot:2
- QUIT
- +4 FOR
- SET DTE=$ORDER(^PS(55,DFN,"P","A",DTE))
- if 'DTE
- QUIT
- FOR IEN=0:0
- SET IEN=$ORDER(^PS(55,DFN,"P","A",DTE,IEN))
- if 'IEN
- QUIT
- if $PIECE($GET(^PSRX(IEN,"STA")),"^")'=13
- DO PROCESS
- End DoDot:1
- QUIT
- +5 IF $GET(EDATE)
- IF '$GET(SDATE)
- SET DTE=DT-1
- Begin DoDot:1
- +6 FOR
- SET DTE=$ORDER(^PS(55,DFN,"P","A",DTE))
- if 'DTE!(DTE>EDATE)
- QUIT
- FOR IEN=0:0
- SET IEN=$ORDER(^PS(55,DFN,"P","A",DTE,IEN))
- if 'IEN
- QUIT
- if $PIECE($GET(^PSRX(IEN,"STA")),"^")'=13
- DO PROCESS
- End DoDot:1
- QUIT
- +7 SET DTE=DT-1
- FOR
- SET DTE=$ORDER(^PS(55,DFN,"P","A",DTE))
- if 'DTE
- QUIT
- FOR IEN=0:0
- SET IEN=$ORDER(^PS(55,DFN,"P","A",DTE,IEN))
- if 'IEN
- QUIT
- if $PIECE($GET(^PSRX(IEN,"STA")),"^")'=13
- DO PROCESS
- +8 QUIT
- PROF(DFN,LIST,SDATE,EDATE) ;
- +1 DO ^PSO52AP1
- +2 QUIT
- IND ;Indication
- +1 if $PIECE($GET(^PSRX(IEN,"IND")),U)]""
- SET ^TMP($JOB,LIST,DFN,IEN,"IND")=$PIECE($GET(^PSRX(IEN,"IND")),U,1,2)
- +2 QUIT
- DIQ ;process fields
- +1 SET DIQ="PST"
- SET DIQ(0)="IE"
- DO EN^DIQ1
- +2 QUIT