PSDORN0 ;BIR/JPW,LTL - Nurse CS Order Request Entry (continued) ;16 Feb 95
;;3.0;CONTROLLED SUBSTANCES ;**79**;13 Feb 97;Build 20
DIE ;create the order request
S:$G(ORD)<2 PSDEM=1
F L +^PSD(58.8,NAOU,1,PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
S:'$D(^PSD(58.8,NAOU,1,PSDR,3,0)) ^(0)="^58.800118A^^"
DIE2 S PSDA=$P(^PSD(58.8,NAOU,1,PSDR,3,0),"^",3)+1 I $D(^PSD(58.8,NAOU,1,PSDR,3,PSDA)) S $P(^PSD(58.8,NAOU,1,PSDR,3,0),"^",3)=$P(^PSD(58.8,NAOU,1,PSDR,3,0),"^",3)+1 G DIE2
K DA,DIC,DIE,DD,DR,DO S DIC(0)="L",(DIC,DIE)="^PSD(58.8,"_NAOU_",1,"_PSDR_",3,",DA(2)=NAOU,DA(1)=PSDR,(X,DINUM)=PSDA D FILE^DICN K DIC
L -^PSD(58.8,NAOU,1,PSDR,0)
D NOW^%DTC S PSDT=+$E(%,1,12) W ?10,!!,"processing now..."
I $G(PAT),$G(PSD(2)),$O(^PSD(58.81,PSD(2),2,0)),'$G(PSD(4)) S ^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,0)=^PSD(58.81,PSD(2),2,0) D
.F WORD=0:0 S WORD=$O(^PSD(58.81,PSD(2),2,WORD)) Q:'WORD S ^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,WORD,0)=^PSD(58.81,PSD(2),2,WORD,0)
S DA=PSDA,DA(1)=PSDR,DA(2)=NAOU,DR="1////"_PSDT_";2////"_+PSDS_";3////"_PSDUZ_";10////1;5////"_PSDQTY_";24////"_$G(PSDEM)_";13//"_$G(PSDR(1)) D ^DIE K DIE,DR,WORD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDORN0 1135 printed Dec 13, 2024@01:47:36 Page 2
PSDORN0 ;BIR/JPW,LTL - Nurse CS Order Request Entry (continued) ;16 Feb 95
+1 ;;3.0;CONTROLLED SUBSTANCES ;**79**;13 Feb 97;Build 20
DIE ;create the order request
+1 if $GET(ORD)<2
SET PSDEM=1
+2 FOR
LOCK +^PSD(58.8,NAOU,1,PSDR,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+3 if '$DATA(^PSD(58.8,NAOU,1,PSDR,3,0))
SET ^(0)="^58.800118A^^"
DIE2 SET PSDA=$PIECE(^PSD(58.8,NAOU,1,PSDR,3,0),"^",3)+1
IF $DATA(^PSD(58.8,NAOU,1,PSDR,3,PSDA))
SET $PIECE(^PSD(58.8,NAOU,1,PSDR,3,0),"^",3)=$PIECE(^PSD(58.8,NAOU,1,PSDR,3,0),"^",3)+1
GOTO DIE2
+1 KILL DA,DIC,DIE,DD,DR,DO
SET DIC(0)="L"
SET (DIC,DIE)="^PSD(58.8,"_NAOU_",1,"_PSDR_",3,"
SET DA(2)=NAOU
SET DA(1)=PSDR
SET (X,DINUM)=PSDA
DO FILE^DICN
KILL DIC
+2 LOCK -^PSD(58.8,NAOU,1,PSDR,0)
+3 DO NOW^%DTC
SET PSDT=+$EXTRACT(%,1,12)
WRITE ?10,!!,"processing now..."
+4 IF $GET(PAT)
IF $GET(PSD(2))
IF $ORDER(^PSD(58.81,PSD(2),2,0))
IF '$GET(PSD(4))
SET ^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,0)=^PSD(58.81,PSD(2),2,0)
Begin DoDot:1
+5 FOR WORD=0:0
SET WORD=$ORDER(^PSD(58.81,PSD(2),2,WORD))
if 'WORD
QUIT
SET ^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,WORD,0)=^PSD(58.81,PSD(2),2,WORD,0)
End DoDot:1
+6 SET DA=PSDA
SET DA(1)=PSDR
SET DA(2)=NAOU
SET DR="1////"_PSDT_";2////"_+PSDS_";3////"_PSDUZ_";10////1;5////"_PSDQTY_";24////"_$GET(PSDEM)_";13//"_$GET(PSDR(1))
DO ^DIE
KILL DIE,DR,WORD
+7 QUIT
