Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSBML1

PSBML1.m

Go to the documentation of this file.
  1. PSBML1 ;BIRMINGHAM/VRN-BCMA API TO IPM FOR EXPIRING ONE-TIME ORDERS ;Mar 2004
  1. ;;3.0;BAR CODE MED ADMIN;**3**;Mar 2004
  1. ;
  1. ; Reference/IA
  1. ; EN^PSJBCMA3/3320
  1. ; ENE^PSJBCMA4/3416
  1. ; ENR^PSJBCMA4/3416
  1. ; ^XUSEC/10076
  1. ;
  1. EXPIRE ;
  1. S PSBFLAG=0,(X,Y)=""
  1. F S X=$O(^PSB(53.79,"AOIP",PSBREC(0),PSBREC(4),X),-1) Q:X="" D
  1. .F S Y=$O(^PSB(53.79,"AOIP",PSBREC(0),PSBREC(4),X,Y),-1) Q:'Y D
  1. ..I $D(^PSB(53.79,Y,.3)),$G(^PSB(53.79,Y,.3,1,0))["Manual" S PSBFLAG=1
  1. ..D:('PSBFLAG)&($P(^PSB(53.79,Y,0),U,9)="G") ENE^PSJBCMA4(PSBREC(0),PSBREC(1)) S (X,Y)=0
  1. Q
  1. ;
  1. COMMENT ;
  1. S PSBIEN="+1,"_PSBIEN_","
  1. D VAL^PSBML(53.793,PSBIEN,.01,PSBREC(0))
  1. S PSBFDA(53.793,PSBIEN,.02)=DUZ
  1. S PSBFDA(53.793,PSBIEN,.03)=PSBNOW
  1. D FILEIT^PSBML
  1. Q
  1. ;
  1. PRN ;
  1. S PSBIEN=PSBIEN_","
  1. D VAL^PSBML(53.79,PSBIEN,.22,PSBREC(0))
  1. D FILEIT^PSBML
  1. Q
  1. UPDATE ;
  1. S PSBIEN=PSBIEN_","
  1. I "^G^N^H^R^RM^S^C^I^"[U_PSBREC(0)_U D
  1. .D VAL^PSBML(53.79,PSBIEN,.06,PSBNOW)
  1. .D VAL^PSBML(53.79,PSBIEN,.07,"`"_DUZ)
  1. .D VAL^PSBML(53.79,PSBIEN,.09,PSBREC(0))
  1. .I $D(PSBREC(3)),PSBREC(3)]"" D VAL^PSBML(53.79,PSBIEN,.26,PSBREC(3))
  1. D:PSBREC(1)]""
  1. .I (PSBREC(0)="N"),($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="G") S PSBREC(1)="Not Given: "_PSBREC(1)
  1. .I ((PSBREC(0)="N")!(PSBREC(0)="G")),($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="RM") S PSBREC(1)="Undo Remove: "_PSBREC(1)
  1. .S:PSBREC(0)="H" PSBREC(1)="Held: "_PSBREC(1)
  1. .S:PSBREC(0)="R" PSBREC(1)="Refused: "_PSBREC(1)
  1. .S:PSBREC(0)="RM" PSBREC(1)="Removed: "_PSBREC(1)
  1. .D VAL^PSBML(53.793,"+2,"_PSBIEN,.01,PSBREC(1))
  1. .D VAL^PSBML(53.793,"+2,"_PSBIEN,.02,"`"_DUZ)
  1. .D VAL^PSBML(53.793,"+2,"_PSBIEN,.03,PSBNOW)
  1. S PSBXDFN=$$GET1^DIQ(53.79,PSBIEN,.01,"I")
  1. I ($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="RM"),((PSBREC(0)="N")!(PSBREC(0)="G")) D
  1. .I '(($D(^XUSEC("PSB MANAGER",DUZ)))!($$GET1^DIQ(53.79,+PSBIEN,.07,"I")=DUZ)) S RESULTS(0)="-1^Verify PSB MANAGER allocation" Q
  1. .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
  1. ..I PSBXDAT["Set to 'GIVEN'" D
  1. ...S PSBXORN=$$GET1^DIQ(53.79,+PSBIEN,.11,"I")
  1. ...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
  1. ...S PSBXDT=PSBXDATE F S PSBXDT=$O(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT)) Q:PSBXDT="" D Q:+$G(RESULTS(0))<0
  1. ....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
  1. ...I '(+$G(RESULTS(0))<0) D S PSBGIVEN=1
  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")
  1. ..D:('(+$G(RESULTS(0))<0))&('PSBGIVEN)&($G(PSBXPTCH))&(PSBYY'>1)
  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),":")
  1. ...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
  1. ;If set to not given then set dose given to 0
  1. Q:(+$G(RESULTS(0))<0)
  1. S:$G(PSBGIVEN) PSBREC(0)="G"
  1. I PSBREC(0)="N",($$GET1^DIQ(53.79,PSBIEN,.09,"I")="G") D:$D(^PSB(53.79,+PSBIEN,.5,0))
  1. .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
  1. I $G(PSBREC(2))]"" D VAL^PSBML(53.79,PSBIEN,.16,PSBREC(2))
  1. S PSBOLDUZ=$P(^PSB(53.79,+PSBIEN,0),U,7),PSBOLSTS=$P(^PSB(53.79,+PSBIEN,0),U,9)
  1. I $G(PSBREC(4))]"" D ; DD/SOL/ADD
  1. .I PSBREC(0)="G"!(PSBREC(0)="I")!(PSBREC(0)="H")!(PSBREC(0)="R")!(PSBREC(0)="M") D ; Only apply if given or infusing
  1. ..K ^PSB(53.79,+PSBIEN,.5),^PSB(53.79,+PSBIEN,.6),^PSB(53.79,+PSBIEN,.7)
  1. ..F PSBCNT=4:1 Q:'$D(PSBREC(PSBCNT)) D
  1. ...S Y=$P(PSBREC(PSBCNT),U)
  1. ...S PSBDD=$S(Y="DD":53.795,Y="ADD":53.796,Y="SOL":53.797,1:0)
  1. ...Q:'PSBDD
  1. ...S PSBIENS="+"_PSBCNT_","_PSBIEN
  1. ...D VAL^PSBML(PSBDD,PSBIENS,.01,"`"_$P(PSBREC(PSBCNT),U,2))
  1. ...D VAL^PSBML(PSBDD,PSBIENS,.02,$P(PSBREC(PSBCNT),U,3))
  1. ...D VAL^PSBML(PSBDD,PSBIENS,.03,$P(PSBREC(PSBCNT),U,4))
  1. ...D:Y="DD" VAL^PSBML(PSBDD,PSBIENS,.04,$P(PSBREC(PSBCNT),U,5))
  1. D FILEIT^PSBML
  1. ; add audit for change of status
  1. ; tell pharmacy if change of status on pharmacy generated UID
  1. I $P($G(RESULTS(0)),U,1)=1 D
  1. .S PSBUID=$P(^PSB(53.79,+PSBIEN,0),U,10) I PSBUID]"",PSBUID'["WS" D
  1. ..S PSBON=$P(^PSB(53.79,+PSBIEN,.1),U,1)
  1. ..S PSBDFN=$P(^PSB(53.79,+PSBIEN,0),U,1)
  1. ..I PSBREC(0)="N" S PSBREC(0)="" D
  1. ...M PSBAR=^PSB(53.79,+PSBIEN,.9)
  1. ...S (PSBDN,X)="" F S X=$O(PSBAR(X),-1) Q:X=0!(PSBDN=1) D
  1. ....I PSBAR(X,0)["ACTION STATUS",PSBAR(X,0)["deleted",PSBAR(X,0)'["GIVEN" D
  1. .....S PSBTS=$P($P(PSBAR(X,0),"'",2),"'",1)
  1. .....S PSBREC(0)=$S(PSBTS="HELD":"H",PSBTS="REFUSED":"R",PSBTS="REMOVED":"RM",PSBTS="MISSING":"M",1:""),PSBDN=1
  1. ..I PSBREC(0)="" D VAL^PSBML(53.79,PSBIEN,.26,"") D CLEAN^DILF,UPDATE^DIE("","PSBFDA","PSBIEN","PSBMSG")
  1. ..D EN^PSJBCMA3(PSBDFN,+PSBON,PSBUID,PSBREC(0),PSBNOW)
  1. 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))
  1. 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))
  1. Q