- PSBML1 ;BIRMINGHAM/VRN-BCMA API TO IPM FOR EXPIRING ONE-TIME ORDERS ;Mar 2004
- ;;3.0;BAR CODE MED ADMIN;**3**;Mar 2004
- ;
- ; Reference/IA
- ; EN^PSJBCMA3/3320
- ; ENE^PSJBCMA4/3416
- ; ENR^PSJBCMA4/3416
- ; ^XUSEC/10076
- ;
- EXPIRE ;
- S PSBFLAG=0,(X,Y)=""
- F S X=$O(^PSB(53.79,"AOIP",PSBREC(0),PSBREC(4),X),-1) Q:X="" D
- .F S Y=$O(^PSB(53.79,"AOIP",PSBREC(0),PSBREC(4),X,Y),-1) Q:'Y D
- ..I $D(^PSB(53.79,Y,.3)),$G(^PSB(53.79,Y,.3,1,0))["Manual" S PSBFLAG=1
- ..D:('PSBFLAG)&($P(^PSB(53.79,Y,0),U,9)="G") ENE^PSJBCMA4(PSBREC(0),PSBREC(1)) S (X,Y)=0
- Q
- ;
- S PSBIEN="+1,"_PSBIEN_","
- D VAL^PSBML(53.793,PSBIEN,.01,PSBREC(0))
- S PSBFDA(53.793,PSBIEN,.02)=DUZ
- S PSBFDA(53.793,PSBIEN,.03)=PSBNOW
- D FILEIT^PSBML
- Q
- ;
- PRN ;
- S PSBIEN=PSBIEN_","
- D VAL^PSBML(53.79,PSBIEN,.22,PSBREC(0))
- D FILEIT^PSBML
- Q
- UPDATE ;
- S PSBIEN=PSBIEN_","
- I "^G^N^H^R^RM^S^C^I^"[U_PSBREC(0)_U D
- .D VAL^PSBML(53.79,PSBIEN,.06,PSBNOW)
- .D VAL^PSBML(53.79,PSBIEN,.07,"`"_DUZ)
- .D VAL^PSBML(53.79,PSBIEN,.09,PSBREC(0))
- .I $D(PSBREC(3)),PSBREC(3)]"" D VAL^PSBML(53.79,PSBIEN,.26,PSBREC(3))
- D:PSBREC(1)]""
- .I (PSBREC(0)="N"),($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="G") S PSBREC(1)="Not Given: "_PSBREC(1)
- .I ((PSBREC(0)="N")!(PSBREC(0)="G")),($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="RM") S PSBREC(1)="Undo Remove: "_PSBREC(1)
- .S:PSBREC(0)="H" PSBREC(1)="Held: "_PSBREC(1)
- .S:PSBREC(0)="R" PSBREC(1)="Refused: "_PSBREC(1)
- .S:PSBREC(0)="RM" PSBREC(1)="Removed: "_PSBREC(1)
- .D VAL^PSBML(53.793,"+2,"_PSBIEN,.01,PSBREC(1))
- .D VAL^PSBML(53.793,"+2,"_PSBIEN,.02,"`"_DUZ)
- .D VAL^PSBML(53.793,"+2,"_PSBIEN,.03,PSBNOW)
- S PSBXDFN=$$GET1^DIQ(53.79,PSBIEN,.01,"I")
- I ($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="RM"),((PSBREC(0)="N")!(PSBREC(0)="G")) D
- .I '(($D(^XUSEC("PSB MANAGER",DUZ)))!($$GET1^DIQ(53.79,+PSBIEN,.07,"I")=DUZ)) S RESULTS(0)="-1^Verify PSB MANAGER allocation" Q
- .S PSBXPTCH=1,PSBYY="",PSBGIVEN=0 F S PSBYY=$O(^PSB(53.79,+PSBIEN,.9,PSBYY),-1) Q:'PSBYY Q:(+$G(RESULTS(0))<0) Q:PSBGIVEN S PSBXDAT=$G(^(PSBYY,0)) D
- ..I PSBXDAT["Set to 'GIVEN'" D
- ...S PSBXORN=$$GET1^DIQ(53.79,+PSBIEN,.11,"I")
- ...F PSBYX=(PSBYY-2):-1:0 Q:PSBYX<1 I ^PSB(53.79,+PSBIEN,.9,PSBYX,0)["ACTION DATE/TIME Set to" S PSBXDATE=$P(^PSB(53.79,+PSBIEN,.9,PSBYX,0),"'",2),X=$P(PSBXDATE,"@"),%DT="" D ^%DT S PSBXDATE=Y_"."_$TR($P(PSBXDATE,"@",2),":") Q
- ...S PSBXDT=PSBXDATE F S PSBXDT=$O(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT)) Q:PSBXDT="" D Q:+$G(RESULTS(0))<0
- ....S PSBYZ="" F S PSBYZ=$O(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT,PSBYZ)) Q:'PSBYZ I $$GET1^DIQ(53.79,PSBYZ,.09,"I")="G" S RESULTS(0)="-1^Cannot UNDO! Order has GIVEN patch" Q
- ...I '(+$G(RESULTS(0))<0) D S PSBGIVEN=1
- ....D VAL^PSBML(53.79,PSBIEN,.06,PSBXDATE),VAL^PSBML(53.79,PSBIEN,.07,"`"_$P(PSBXDAT,U,2)),VAL^PSBML(53.79,PSBIEN,.09,"G")
- ..D:('(+$G(RESULTS(0))<0))&('PSBGIVEN)&($G(PSBXPTCH))&(PSBYY'>1)
- ...S PSBXDATE=$P(^PSB(53.79,+PSBIEN,.9,PSBYY,0),"'",2),X=$P(PSBXDATE,"@"),%DT="" D ^%DT S PSBXDATE=Y_"."_$TR($P(PSBXDATE,"@",2),":")
- ...D VAL^PSBML(53.79,PSBIEN,.06,PSBXDATE),VAL^PSBML(53.79,PSBIEN,.07,"`"_$$GET1^DIQ(53.79,+PSBIEN,.07,"I")),VAL^PSBML(53.79,PSBIEN,.09,"G") S PSBGIVEN=1
- ;If set to not given then set dose given to 0
- Q:(+$G(RESULTS(0))<0)
- S:$G(PSBGIVEN) PSBREC(0)="G"
- I PSBREC(0)="N",($$GET1^DIQ(53.79,PSBIEN,.09,"I")="G") D:$D(^PSB(53.79,+PSBIEN,.5,0))
- .S PSBX=0 F S PSBX=$O(^PSB(53.79,$P(PSBIEN,","),.5,PSBX)) Q:'(+PSBX) S $P(^PSB(53.79,$P(PSBIEN,","),.5,PSBX,0),"^",3)=0
- I $G(PSBREC(2))]"" D VAL^PSBML(53.79,PSBIEN,.16,PSBREC(2))
- S PSBOLDUZ=$P(^PSB(53.79,+PSBIEN,0),U,7),PSBOLSTS=$P(^PSB(53.79,+PSBIEN,0),U,9)
- I $G(PSBREC(4))]"" D ; DD/SOL/ADD
- .I PSBREC(0)="G"!(PSBREC(0)="I")!(PSBREC(0)="H")!(PSBREC(0)="R")!(PSBREC(0)="M") D ; Only apply if given or infusing
- ..K ^PSB(53.79,+PSBIEN,.5),^PSB(53.79,+PSBIEN,.6),^PSB(53.79,+PSBIEN,.7)
- ..F PSBCNT=4:1 Q:'$D(PSBREC(PSBCNT)) D
- ...S Y=$P(PSBREC(PSBCNT),U)
- ...S PSBDD=$S(Y="DD":53.795,Y="ADD":53.796,Y="SOL":53.797,1:0)
- ...Q:'PSBDD
- ...S PSBIENS="+"_PSBCNT_","_PSBIEN
- ...D VAL^PSBML(PSBDD,PSBIENS,.01,"`"_$P(PSBREC(PSBCNT),U,2))
- ...D VAL^PSBML(PSBDD,PSBIENS,.02,$P(PSBREC(PSBCNT),U,3))
- ...D VAL^PSBML(PSBDD,PSBIENS,.03,$P(PSBREC(PSBCNT),U,4))
- ...D:Y="DD" VAL^PSBML(PSBDD,PSBIENS,.04,$P(PSBREC(PSBCNT),U,5))
- D FILEIT^PSBML
- ; add audit for change of status
- ; tell pharmacy if change of status on pharmacy generated UID
- I $P($G(RESULTS(0)),U,1)=1 D
- .S PSBUID=$P(^PSB(53.79,+PSBIEN,0),U,10) I PSBUID]"",PSBUID'["WS" D
- ..S PSBON=$P(^PSB(53.79,+PSBIEN,.1),U,1)
- ..S PSBDFN=$P(^PSB(53.79,+PSBIEN,0),U,1)
- ..I PSBREC(0)="N" S PSBREC(0)="" D
- ...M PSBAR=^PSB(53.79,+PSBIEN,.9)
- ...S (PSBDN,X)="" F S X=$O(PSBAR(X),-1) Q:X=0!(PSBDN=1) D
- ....I PSBAR(X,0)["ACTION STATUS",PSBAR(X,0)["deleted",PSBAR(X,0)'["GIVEN" D
- .....S PSBTS=$P($P(PSBAR(X,0),"'",2),"'",1)
- .....S PSBREC(0)=$S(PSBTS="HELD":"H",PSBTS="REFUSED":"R",PSBTS="REMOVED":"RM",PSBTS="MISSING":"M",1:""),PSBDN=1
- ..I PSBREC(0)="" D VAL^PSBML(53.79,PSBIEN,.26,"") D CLEAN^DILF,UPDATE^DIE("","PSBFDA","PSBIEN","PSBMSG")
- ..D EN^PSJBCMA3(PSBDFN,+PSBON,PSBUID,PSBREC(0),PSBNOW)
- I ($$GET1^DIQ(53.79,+PSBIEN,.12,"I")="O")&($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="N") S PSBDFN=$$GET1^DIQ(53.79,+PSBIEN,.01,"I") D ENR^PSJBCMA4(PSBDFN,$$GET1^DIQ(53.79,+PSBIEN,.11))
- I ($$GET1^DIQ(53.79,+PSBIEN,.12,"I")="O")&($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="G") S PSBDFN=$$GET1^DIQ(53.79,+PSBIEN,.01,"I") D ENE^PSJBCMA4(PSBDFN,$$GET1^DIQ(53.79,+PSBIEN,.11))
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBML1 5516 printed Jan 18, 2025@02:41:21 Page 2
- PSBML1 ;BIRMINGHAM/VRN-BCMA API TO IPM FOR EXPIRING ONE-TIME ORDERS ;Mar 2004
- +1 ;;3.0;BAR CODE MED ADMIN;**3**;Mar 2004
- +2 ;
- +3 ; Reference/IA
- +4 ; EN^PSJBCMA3/3320
- +5 ; ENE^PSJBCMA4/3416
- +6 ; ENR^PSJBCMA4/3416
- +7 ; ^XUSEC/10076
- +8 ;
- EXPIRE ;
- +1 SET PSBFLAG=0
- SET (X,Y)=""
- +2 FOR
- SET X=$ORDER(^PSB(53.79,"AOIP",PSBREC(0),PSBREC(4),X),-1)
- if X=""
- QUIT
- Begin DoDot:1
- +3 FOR
- SET Y=$ORDER(^PSB(53.79,"AOIP",PSBREC(0),PSBREC(4),X,Y),-1)
- if 'Y
- QUIT
- Begin DoDot:2
- +4 IF $DATA(^PSB(53.79,Y,.3))
- IF $GET(^PSB(53.79,Y,.3,1,0))["Manual"
- SET PSBFLAG=1
- +5 if ('PSBFLAG)&($PIECE(^PSB(53.79,Y,0),U,9)="G")
- DO ENE^PSJBCMA4(PSBREC(0),PSBREC(1))
- SET (X,Y)=0
- End DoDot:2
- End DoDot:1
- +6 QUIT
- +7 ;
- +1 SET PSBIEN="+1,"_PSBIEN_","
- +2 DO VAL^PSBML(53.793,PSBIEN,.01,PSBREC(0))
- +3 SET PSBFDA(53.793,PSBIEN,.02)=DUZ
- +4 SET PSBFDA(53.793,PSBIEN,.03)=PSBNOW
- +5 DO FILEIT^PSBML
- +6 QUIT
- +7 ;
- PRN ;
- +1 SET PSBIEN=PSBIEN_","
- +2 DO VAL^PSBML(53.79,PSBIEN,.22,PSBREC(0))
- +3 DO FILEIT^PSBML
- +4 QUIT
- UPDATE ;
- +1 SET PSBIEN=PSBIEN_","
- +2 IF "^G^N^H^R^RM^S^C^I^"[U_PSBREC(0)_U
- Begin DoDot:1
- +3 DO VAL^PSBML(53.79,PSBIEN,.06,PSBNOW)
- +4 DO VAL^PSBML(53.79,PSBIEN,.07,"`"_DUZ)
- +5 DO VAL^PSBML(53.79,PSBIEN,.09,PSBREC(0))
- +6 IF $DATA(PSBREC(3))
- IF PSBREC(3)]""
- DO VAL^PSBML(53.79,PSBIEN,.26,PSBREC(3))
- End DoDot:1
- +7 if PSBREC(1)]""
- Begin DoDot:1
- +8 IF (PSBREC(0)="N")
- IF ($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="G")
- SET PSBREC(1)="Not Given: "_PSBREC(1)
- +9 IF ((PSBREC(0)="N")!(PSBREC(0)="G"))
- IF ($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="RM")
- SET PSBREC(1)="Undo Remove: "_PSBREC(1)
- +10 if PSBREC(0)="H"
- SET PSBREC(1)="Held: "_PSBREC(1)
- +11 if PSBREC(0)="R"
- SET PSBREC(1)="Refused: "_PSBREC(1)
- +12 if PSBREC(0)="RM"
- SET PSBREC(1)="Removed: "_PSBREC(1)
- +13 DO VAL^PSBML(53.793,"+2,"_PSBIEN,.01,PSBREC(1))
- +14 DO VAL^PSBML(53.793,"+2,"_PSBIEN,.02,"`"_DUZ)
- +15 DO VAL^PSBML(53.793,"+2,"_PSBIEN,.03,PSBNOW)
- End DoDot:1
- +16 SET PSBXDFN=$$GET1^DIQ(53.79,PSBIEN,.01,"I")
- +17 IF ($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="RM")
- IF ((PSBREC(0)="N")!(PSBREC(0)="G"))
- Begin DoDot:1
- +18 IF '(($DATA(^XUSEC("PSB MANAGER",DUZ)))!($$GET1^DIQ(53.79,+PSBIEN,.07,"I")=DUZ))
- SET RESULTS(0)="-1^Verify PSB MANAGER allocation"
- QUIT
- +19 SET PSBXPTCH=1
- SET PSBYY=""
- SET PSBGIVEN=0
- FOR
- SET PSBYY=$ORDER(^PSB(53.79,+PSBIEN,.9,PSBYY),-1)
- if 'PSBYY
- QUIT
- if (+$GET(RESULTS(0))<0)
- QUIT
- if PSBGIVEN
- QUIT
- SET PSBXDAT=$GET(^(PSBYY,0))
- Begin DoDot:2
- +20 IF PSBXDAT["Set to 'GIVEN'"
- Begin DoDot:3
- +21 SET PSBXORN=$$GET1^DIQ(53.79,+PSBIEN,.11,"I")
- +22 FOR PSBYX=(PSBYY-2):-1:0
- if PSBYX<1
- QUIT
- IF ^PSB(53.79,+PSBIEN,.9,PSBYX,0)["ACTION DATE/TIME Set to"
- SET PSBXDATE=$PIECE(^PSB(53.79,+PSBIEN,.9,PSBYX,0),"'",2)
- SET X=$PIECE(PSBXDATE,"@")
- SET %DT=""
- DO ^%DT
- SET PSBXDATE=Y_"."_$TRANSLATE($PIECE(PSBXDATE,"@",2),":")
- QUIT
- +23 SET PSBXDT=PSBXDATE
- FOR
- SET PSBXDT=$ORDER(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT))
- if PSBXDT=""
- QUIT
- Begin DoDot:4
- +24 SET PSBYZ=""
- FOR
- SET PSBYZ=$ORDER(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT,PSBYZ))
- if 'PSBYZ
- QUIT
- IF $$GET1^DIQ(53.79,PSBYZ,.09,"I")="G"
- SET RESULTS(0)="-1^Cannot UNDO! Order has GIVEN patch"
- QUIT
- End DoDot:4
- if +$GET(RESULTS(0))<0
- QUIT
- +25 IF '(+$GET(RESULTS(0))<0)
- Begin DoDot:4
- +26 DO VAL^PSBML(53.79,PSBIEN,.06,PSBXDATE)
- DO VAL^PSBML(53.79,PSBIEN,.07,"`"_$PIECE(PSBXDAT,U,2))
- DO VAL^PSBML(53.79,PSBIEN,.09,"G")
- End DoDot:4
- SET PSBGIVEN=1
- End DoDot:3
- +27 if ('(+$GET(RESULTS(0))<0))&('PSBGIVEN)&($GET(PSBXPTCH))&(PSBYY'>1)
- Begin DoDot:3
- +28 SET PSBXDATE=$PIECE(^PSB(53.79,+PSBIEN,.9,PSBYY,0),"'",2)
- SET X=$PIECE(PSBXDATE,"@")
- SET %DT=""
- DO ^%DT
- SET PSBXDATE=Y_"."_$TRANSLATE($PIECE(PSBXDATE,"@",2),":")
- +29 DO VAL^PSBML(53.79,PSBIEN,.06,PSBXDATE)
- DO VAL^PSBML(53.79,PSBIEN,.07,"`"_$$GET1^DIQ(53.79,+PSBIEN,.07,"I"))
- DO VAL^PSBML(53.79,PSBIEN,.09,"G")
- SET PSBGIVEN=1
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +30 ;If set to not given then set dose given to 0
- +31 if (+$GET(RESULTS(0))<0)
- QUIT
- +32 if $GET(PSBGIVEN)
- SET PSBREC(0)="G"
- +33 IF PSBREC(0)="N"
- IF ($$GET1^DIQ(53.79,PSBIEN,.09,"I")="G")
- if $DATA(^PSB(53.79,+PSBIEN,.5,0))
- Begin DoDot:1
- +34 SET PSBX=0
- FOR
- SET PSBX=$ORDER(^PSB(53.79,$PIECE(PSBIEN,","),.5,PSBX))
- if '(+PSBX)
- QUIT
- SET $PIECE(^PSB(53.79,$PIECE(PSBIEN,","),.5,PSBX,0),"^",3)=0
- End DoDot:1
- +35 IF $GET(PSBREC(2))]""
- DO VAL^PSBML(53.79,PSBIEN,.16,PSBREC(2))
- +36 SET PSBOLDUZ=$PIECE(^PSB(53.79,+PSBIEN,0),U,7)
- SET PSBOLSTS=$PIECE(^PSB(53.79,+PSBIEN,0),U,9)
- +37 ; DD/SOL/ADD
- IF $GET(PSBREC(4))]""
- Begin DoDot:1
- +38 ; Only apply if given or infusing
- IF PSBREC(0)="G"!(PSBREC(0)="I")!(PSBREC(0)="H")!(PSBREC(0)="R")!(PSBREC(0)="M")
- Begin DoDot:2
- +39 KILL ^PSB(53.79,+PSBIEN,.5),^PSB(53.79,+PSBIEN,.6),^PSB(53.79,+PSBIEN,.7)
- +40 FOR PSBCNT=4:1
- if '$DATA(PSBREC(PSBCNT))
- QUIT
- Begin DoDot:3
- +41 SET Y=$PIECE(PSBREC(PSBCNT),U)
- +42 SET PSBDD=$SELECT(Y="DD":53.795,Y="ADD":53.796,Y="SOL":53.797,1:0)
- +43 if 'PSBDD
- QUIT
- +44 SET PSBIENS="+"_PSBCNT_","_PSBIEN
- +45 DO VAL^PSBML(PSBDD,PSBIENS,.01,"`"_$PIECE(PSBREC(PSBCNT),U,2))
- +46 DO VAL^PSBML(PSBDD,PSBIENS,.02,$PIECE(PSBREC(PSBCNT),U,3))
- +47 DO VAL^PSBML(PSBDD,PSBIENS,.03,$PIECE(PSBREC(PSBCNT),U,4))
- +48 if Y="DD"
- DO VAL^PSBML(PSBDD,PSBIENS,.04,$PIECE(PSBREC(PSBCNT),U,5))
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +49 DO FILEIT^PSBML
- +50 ; add audit for change of status
- +51 ; tell pharmacy if change of status on pharmacy generated UID
- +52 IF $PIECE($GET(RESULTS(0)),U,1)=1
- Begin DoDot:1
- +53 SET PSBUID=$PIECE(^PSB(53.79,+PSBIEN,0),U,10)
- IF PSBUID]""
- IF PSBUID'["WS"
- Begin DoDot:2
- +54 SET PSBON=$PIECE(^PSB(53.79,+PSBIEN,.1),U,1)
- +55 SET PSBDFN=$PIECE(^PSB(53.79,+PSBIEN,0),U,1)
- +56 IF PSBREC(0)="N"
- SET PSBREC(0)=""
- Begin DoDot:3
- +57 MERGE PSBAR=^PSB(53.79,+PSBIEN,.9)
- +58 SET (PSBDN,X)=""
- FOR
- SET X=$ORDER(PSBAR(X),-1)
- if X=0!(PSBDN=1)
- QUIT
- Begin DoDot:4
- +59 IF PSBAR(X,0)["ACTION STATUS"
- IF PSBAR(X,0)["deleted"
- IF PSBAR(X,0)'["GIVEN"
- Begin DoDot:5
- +60 SET PSBTS=$PIECE($PIECE(PSBAR(X,0),"'",2),"'",1)
- +61 SET PSBREC(0)=$SELECT(PSBTS="HELD":"H",PSBTS="REFUSED":"R",PSBTS="REMOVED":"RM",PSBTS="MISSING":"M",1:"")
- SET PSBDN=1
- End DoDot:5
- End DoDot:4
- End DoDot:3
- +62 IF PSBREC(0)=""
- DO VAL^PSBML(53.79,PSBIEN,.26,"")
- DO CLEAN^DILF
- DO UPDATE^DIE("","PSBFDA","PSBIEN","PSBMSG")
- +63 DO EN^PSJBCMA3(PSBDFN,+PSBON,PSBUID,PSBREC(0),PSBNOW)
- End DoDot:2
- End DoDot:1
- +64 IF ($$GET1^DIQ(53.79,+PSBIEN,.12,"I")="O")&($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="N")
- SET PSBDFN=$$GET1^DIQ(53.79,+PSBIEN,.01,"I")
- DO ENR^PSJBCMA4(PSBDFN,$$GET1^DIQ(53.79,+PSBIEN,.11))
- +65 IF ($$GET1^DIQ(53.79,+PSBIEN,.12,"I")="O")&($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="G")
- SET PSBDFN=$$GET1^DIQ(53.79,+PSBIEN,.01,"I")
- DO ENE^PSJBCMA4(PSBDFN,$$GET1^DIQ(53.79,+PSBIEN,.11))
- +66 QUIT