- PSGOD ;BIR/CML - CREATES NEW ORDER FROM OLD ONE ;Jul 27, 2020@09:22:09
- ;;5.0;INPATIENT MEDICATIONS;**67,58,111,133,181,286,281,315,338,256,347,367,327,399,372**;16 DEC 97;Build 153
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ; Reference to ^PS(55 is supported by DBIA 2191.
- ; Reference to ^YSCLTST5 is supported by DBIA 7188.
- ; Reference to $$SDEA^XUSER supported by DBIA 2343
- ;
- ;*286 - Do not allow copied Unit Dose orders for outpatients
- D INP^VADPT I 'VAIN(4) W !,"You cannot copy Unit Dose orders for this patient!" H 2 Q
- I $P($G(^PS(55,PSGP,5,+PSJORD,0)),"^",22) D Q
- .W !,"This order is marked 'Not To Be Given' and can't be copied!" H 2
- ; /MZR PSJ*5*327 start
- N CLOZFLG D G:$G(ANQX) DONE
- .S CLOZFLG=$$ISCLOZ^PSJCLOZ(,,PSGP,+PSJORD) Q:'CLOZFLG ; continue just with Clozapine drug
- .N CLOZNUM,CLOZUID
- .S CLOZNUM=$$GET1^DIQ(55,DFN,53)
- .I CLOZNUM'="" S CLOZUID=$$FIND1^DIC(603.01,,"X",CLOZNUM)
- .I '$G(CLOZUID) D Q
- ..W !!,"*** This patient has no clozapine registration number ***"
- ..W !,"*** and must be reregistered ***"
- ..D PAUSE^VALM1 S ANQX=1 Q
- .S CLOZPAT=$$GET1^DIQ(603.01,CLOZUID,2,"I"),CLOZPAT=$S(CLOZPAT="M":2,CLOZPAT="B":1,CLOZPAT="W":0,1:90)
- ; /MZR PSJ*5*327 end
- F W !!,"Do you want to copy this order" S %=2 D YN^DICN Q:% D CH
- G:%'=1 DONE
- ;
- W !!,"...copying..." N OLDON
- K PSGORQF
- N PSGPDRG,Q
- N PSJOLDNM
- S PSGOEPR=$P($G(^PS(55,PSGP,5.1)),"^",2),OLDON=PSGORD,Q=""
- K PSGODN S F=$S(PSGORD["P":"^PS(53.1,"_+PSGORD_",",1:"^PS(55,"_PSGP_",5,"_+PSGORD_",") F N=0,.2,2,2.1,6 S PSGODN(N)=$G(@(F_N_")"))
- S PSGPR=$P(PSGODN(0),"^",2),PSGMR=$P(PSGODN(0),"^",3),PSGSM=$P(PSGODN(0),"^",5),PSGHSM=$P(PSGODN(0),"^",6),PSGST=$P(PSGODN(0),"^",7)
- S PSGPDRG=+PSGODN(.2),PSGDO=$P(PSGODN(.2),"^",2)
- ;
- ;*372
- I $G(PSGPDRG) N PDEA S PDEA="" D I (PDEA=1)!(PDEA=2)!(+PDEA=4) D PAUSE^VALM1 G ORIG
- . N PSJDEA S PSJDEA=$$OIDEA^PSSOPKI(PSGPDRG,"U"),PSJDEA=$P(PSJDEA,";",2)
- . I PSJDEA S PDEA=$$SDEA^XUSER(,+PSGPR,PSJDEA,,"I") I (PDEA=1)!(PDEA=2)!(+PDEA=4) D
- .. W !!,"Provider not authorized to prescribe medications in Federal Schedule "_PSJDEA_".",!,"Please contact the provider.",!
- ;
- ;*315
- S:$G(PSGODN(2.1))]"" PSGDUR=+PSGODN(2.1),PSGRMVT=$P(PSGODN(2.1),U,2),PSGRMV=$P(PSGODN(2.1),U,3),PSGRF=$P(PSGODN(2.1),U,4)
- S PSGSI=PSGODN(6)
- ; The naked reference below refers to the full reference inside indirection to ^PS(55,PSGP,5,+PSGORD, or ^PS(55,PSGP,"IV",+PSGORD, or ^PS(53.1,+PSGORD
- S PSGODN(3)=0 F Q=0:0 S Q=$O(@(F_"3,"_Q_")")) Q:'Q I $D(^(Q,0)) S PSGODN(3,Q)=^(0),PSGODN(3)=PSGODN(3)+1 S ^PS(53.45,PSJSYSP,1,Q,0)=^(0)
- ;S:PSGODN(12)>0 ^PS(53.45,PSJSYSP,4,0)="^53.4504" S:PSGODN(3)>0 ^PS(53.45,PSJSYSP,1,0)="^53.4501"
- S:PSGODN(3)>0 ^PS(53.45,PSJSYSP,1,0)="^53.4501"
- ; The naked reference below refers to the full reference inside indirection to ^PS(55,PSGP,5,+PSGORD, or ^PS(55,PSGP,"IV",+PSGORD, or ^PS(53.1,+PSGORD
- ;338
- N PSGK5345 S PSGK5345=0
- S (PSGODN(1),Q)=0 F S Q=$O(@(F_"1,"_Q_")")) Q:'Q S ND=$G(^(Q,0)) I ND D
- .I '$P(ND,"^",3),'PSGK5345 S PSGODN(1)=PSGODN(1)+1,PSGODN(1,PSGODN(1))=$P(ND,"^",1,2) S ^PS(53.45,PSJSYSP,2,PSGODN(1),0)=^(0)
- .I '$P(ND,"^",3),PSGK5345 S PSGODN(1,PSGODN(1))=$P(ND,"^",1,2) S ^PS(53.45,PSJSYSP,2,PSGODN(1),0)=^(0) S PSGODN(1)=PSGODN(1)+1,PSGK5345=0 K ^PS(53.45,PSJSYSP,2,PSGODN(1),0)
- .I $P(ND,"^",3) S PSGODN(1)=PSGODN(1)+1 K ^PS(53.45,PSJSYSP,2,PSGODN(1),0) S PSGK5345=1
- K PSGK5345
- S PSGS0Y=$P(PSGODN(2),"^",5),PSGS0XT=$P(PSGODN(2),"^",6),PSGNESD="",PSGSCH=$P(PSGODN(2),U)
- ;PSJ*5*256
- S PSJOLDNM("ORD_SCHD")=PSGSCH
- I $$CHKSCHD^PSJMISC2(.PSJOLDNM) W !!,"Order not copied." D PAUSE^VALM1 K PSJOLDNM G ORIG
- S:$G(PSJOLDNM("NEW_SCHD"))]"" PSGSCH=PSJOLDNM("NEW_SCHD") K PSJOLDNM
- S PSGODF=1,PSGNEDFD=$P($$GTNEDFD^PSGOE7("U",+PSGPDRG),U)_"^^"_PSGST_"^"_PSGSCH
- W "." D ^PSGNE3
- K PSGEFN,PSGOEEF,PSGOEE,PSGOEOS S PSGEFN="1:14" F X=1:1:14 S PSGEFN(X)="" ;*399-IND
- S PSGPDN=$$OINAME^PSJLMUTL(PSGPDRG),PSGOINST="",PSGSDN=$$ENDD^PSGMI(PSGNESD)_U_$$ENDTC^PSGMI(PSGNESD),PSGFDN=$$ENDD^PSGMI(PSGNEFD)_U_$$ENDTC^PSGMI(PSGNEFD)
- S PSGAT=PSGS0Y,PSGEBN=DUZ,PSGLIN=$$ENDD^PSGMI(PSGDT)_U_$$ENDTC^PSGMI(PSGDT),PSGEBN=$$ENNPN^PSGMI(DUZ),PSGSTAT=$S(PSGOEAV:"ACTIVE",1:"NON-VERIFIED")
- W "." D CHK^PSGOEV("^^"_PSGMR_"^^^^"_PSGST,PSGPDRG_U_PSGDO,PSGSCH_U_PSGNESD_"^^"_PSGNEFD)
- I $G(PSGSCH)]"" D
- .N X S X=PSGSCH N SWD,SDW,XABB,QX D ENOS^PSGS0 I $G(X)=""!$G(PSJNSS) S CHK=1 K PSJNSS Q
- .I $G(PSGAT)="",$G(PSGS0Y) S PSGAT=PSGS0Y
- .I $G(PSGAT),($G(PSGS0Y)="") S PSGS0Y=PSGAT
- .I $G(PSGS0XT)="D",$G(PSGS0Y)="" S CHK=1 D K PSJNSS
- ..W ! K DIR S DIR(0)="FOA",DIR("A")=" WARNING - Admin times are required for DAY OF WEEK schedules " D ^DIR K DIR
- S PSGSD=PSGNESD,PSGFD=PSGNEFD
- K PSJACEPT S VALMBCK="Q" D:$D(Y) EN^VALM("PSJU LM ACCEPT")
- I $G(PSJACEPT)=1 D OC S:$D(PSGORQF) PSJACEPT=0 S:$G(PSJACEPT)=1 VALMBCK="",PSJNOO=$$ENNOO^PSJUTL5("N")
- I '$G(PSJACEPT)!($G(PSJNOO)<0) W:'$G(PSJCOFLG) !!,"Order not copied." D PAUSE^VALM1:'$G(PSJCOFLG) G ORIG ;PSJCOFLG set in PSODGAL1 for allergies
- S PSGNESD=PSGSD,PSGNEFD=PSGFD
- K PSGOEE D ^PSGOETO S PSJORD=PSGORD I PSGOEAV D
- .I '$D(PSGOEE),+PSJSYSU=3 D EN^PSGPEN(PSGORD)
- .;; START NCC REMEDIATION >> 327*RJS
- .I +$G(PSGCOPY)!(+$G(PSGEDT)) D
- ..I CLOZFLG D
- ...I $D(^TMP($J,"PSGCLOZ",DFN,+$G(PSJORD),"SAND")) D K ^TMP($J,"PSGCLOZ",DFN,+PSJORD,"SAND")
- ....S DIE="^PS(55,"_DFN_",5,",DA=+PSJORD,DA(1)=DFN,DR="301////"_^TMP($J,"PSGCLOZ",DFN,+PSJORD,"SAND") D ^DIE
- ...N PSGDN S PSGDN=$P(CLOZFLG,U,2)
- ...D PSJFILE^PSJCLOZ(DFN),INPSND^YSCLTST5 K:$D(^TMP($J,"CLOZFLG",DFN)) ^TMP($J,"CLOZFLG",DFN)
- .;; END NCC REMEDIATION >> 327*RJS
- .D SETOC^PSJNEWOC(PSGORD) ;RTC 178789 Store allergy if auto vf is on
- D GETUD^PSJLMGUD(PSGP,PSGORD) N PSGOEEF S PSGOEEF=0 D ENSFE^PSGOEE0(PSGP,PSGORD),^PSGOE1,EN^VALM("PSJ LM UD ACTION")
- ;RTC 178789 - store allery if not verified the newly copied order
- I ($G(PSGORD)["P"),($P($G(^PS(53.1,+PSGORD,0)),U,9)="N"),($G(PSJOCFG)="COPY UD") D SETOC^PSJNEWOC(PSGORD)
- ;
- S PSGCANFL=0,(PSGORD,PSJORD)=OLDON W !!,"You are finished with the new order.",!,"The following ACTION prompt is for the original order."
- K DIR S DIR(0)="E" D ^DIR K DIR
- ORIG ;Redisplay original order
- D GETUD^PSJLMGUD(PSGP,OLDON),INIT^PSJLMUDE(PSGP,OLDON)
- DONE ;
- K %,%H,%I,DA,F,N,PSGODN,PSGODF,PSGS0XT,PSGS0Y,PSGNESD,PSGTOL,PSGTOO,PSGUOW,X,Y,^PS(53.45,PSJSYSP,1),^PS(53.45,PSJSYSP,2)
- K PSGPR,PSGMR,PSGSM,PSGHSM,PSGST,PSGPDRG,PSGDO,PSGNEDFD,PSGSCH,PSGNEFD
- Q
- ;
- CH ;
- W !!?2,"Answer 'YES' to have a new, non-verified order created for this patient,",!,"using the information from this order. (The START and STOP dates will be",!,"recalculated.) Enter 'NO' (or '^') to stop now." Q
- ;
- WH ;
- W !!?2,"Answer 'YES' to take action on this new order. Enter 'NO' (or '^') to return",!,"to the original order now." Q
- ;
- OC ;Perform order checks
- NEW PSJDD,X,PSJALLGY
- ;*286 - Order checks on current dispense drugs
- F X=0:0 S X=$O(^PS(53.45,PSJSYSP,2,X)) Q:'X D
- . S PSJDD=$G(^PS(53.45,PSJSYSP,2,X,0))
- . I +PSJDD S PSJALLGY(+PSJDD)=""
- ;S X=+$O(PSGODN(1,0)) Q:'X S PSJDD=+$G(PSGODN(1,X)) Q:'PSJDD
- S PSJDD=+$O(PSJALLGY(0)) Q:'PSJDD
- D FULL^VALM1
- ;; START NCC REMEDIATION >> 327*RJS FOR TOTAL DAILY DOSE
- I CLOZFLG S ANQX=0 D TDD^PSJCLOZ
- Q:$G(PSGORQF)
- ;/RJS Begin PSJ*5.0*327 modification FOR ORDER CHECKS
- S PSJDD=+$O(PSJALLGY(0)) Q:'PSJDD
- D FULL^VALM1
- D ENDDC^PSGSICHK($G(PSGP),PSJDD) Q:$G(PSGORQF)
- D IN^PSJOCDS($G(PSGORD),"UD",PSJDD) Q:$G(PSGORQF)
- D ORD^PSJCLOZ
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOD 7524 printed Mar 13, 2025@21:06:39 Page 2
- PSGOD ;BIR/CML - CREATES NEW ORDER FROM OLD ONE ;Jul 27, 2020@09:22:09
- +1 ;;5.0;INPATIENT MEDICATIONS;**67,58,111,133,181,286,281,315,338,256,347,367,327,399,372**;16 DEC 97;Build 153
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ; Reference to ^PS(55 is supported by DBIA 2191.
- +4 ; Reference to ^YSCLTST5 is supported by DBIA 7188.
- +5 ; Reference to $$SDEA^XUSER supported by DBIA 2343
- +6 ;
- +7 ;*286 - Do not allow copied Unit Dose orders for outpatients
- +8 DO INP^VADPT
- IF 'VAIN(4)
- WRITE !,"You cannot copy Unit Dose orders for this patient!"
- HANG 2
- QUIT
- +9 IF $PIECE($GET(^PS(55,PSGP,5,+PSJORD,0)),"^",22)
- Begin DoDot:1
- +10 WRITE !,"This order is marked 'Not To Be Given' and can't be copied!"
- HANG 2
- End DoDot:1
- QUIT
- +11 ; /MZR PSJ*5*327 start
- +12 NEW CLOZFLG
- Begin DoDot:1
- +13 ; continue just with Clozapine drug
- SET CLOZFLG=$$ISCLOZ^PSJCLOZ(,,PSGP,+PSJORD)
- if 'CLOZFLG
- QUIT
- +14 NEW CLOZNUM,CLOZUID
- +15 SET CLOZNUM=$$GET1^DIQ(55,DFN,53)
- +16 IF CLOZNUM'=""
- SET CLOZUID=$$FIND1^DIC(603.01,,"X",CLOZNUM)
- +17 IF '$GET(CLOZUID)
- Begin DoDot:2
- +18 WRITE !!,"*** This patient has no clozapine registration number ***"
- +19 WRITE !,"*** and must be reregistered ***"
- +20 DO PAUSE^VALM1
- SET ANQX=1
- QUIT
- End DoDot:2
- QUIT
- +21 SET CLOZPAT=$$GET1^DIQ(603.01,CLOZUID,2,"I")
- SET CLOZPAT=$SELECT(CLOZPAT="M":2,CLOZPAT="B":1,CLOZPAT="W":0,1:90)
- End DoDot:1
- if $GET(ANQX)
- GOTO DONE
- +22 ; /MZR PSJ*5*327 end
- +23 FOR
- WRITE !!,"Do you want to copy this order"
- SET %=2
- DO YN^DICN
- if %
- QUIT
- DO CH
- +24 if %'=1
- GOTO DONE
- +25 ;
- +26 WRITE !!,"...copying..."
- NEW OLDON
- +27 KILL PSGORQF
- +28 NEW PSGPDRG,Q
- +29 NEW PSJOLDNM
- +30 SET PSGOEPR=$PIECE($GET(^PS(55,PSGP,5.1)),"^",2)
- SET OLDON=PSGORD
- SET Q=""
- +31 KILL PSGODN
- SET F=$SELECT(PSGORD["P":"^PS(53.1,"_+PSGORD_",",1:"^PS(55,"_PSGP_",5,"_+PSGORD_",")
- FOR N=0,.2,2,2.1,6
- SET PSGODN(N)=$GET(@(F_N_")"))
- +32 SET PSGPR=$PIECE(PSGODN(0),"^",2)
- SET PSGMR=$PIECE(PSGODN(0),"^",3)
- SET PSGSM=$PIECE(PSGODN(0),"^",5)
- SET PSGHSM=$PIECE(PSGODN(0),"^",6)
- SET PSGST=$PIECE(PSGODN(0),"^",7)
- +33 SET PSGPDRG=+PSGODN(.2)
- SET PSGDO=$PIECE(PSGODN(.2),"^",2)
- +34 ;
- +35 ;*372
- +36 IF $GET(PSGPDRG)
- NEW PDEA
- SET PDEA=""
- Begin DoDot:1
- +37 NEW PSJDEA
- SET PSJDEA=$$OIDEA^PSSOPKI(PSGPDRG,"U")
- SET PSJDEA=$PIECE(PSJDEA,";",2)
- +38 IF PSJDEA
- SET PDEA=$$SDEA^XUSER(,+PSGPR,PSJDEA,,"I")
- IF (PDEA=1)!(PDEA=2)!(+PDEA=4)
- Begin DoDot:2
- +39 WRITE !!,"Provider not authorized to prescribe medications in Federal Schedule "_PSJDEA_".",!,"Please contact the provider.",!
- End DoDot:2
- End DoDot:1
- IF (PDEA=1)!(PDEA=2)!(+PDEA=4)
- DO PAUSE^VALM1
- GOTO ORIG
- +40 ;
- +41 ;*315
- +42 if $GET(PSGODN(2.1))]""
- SET PSGDUR=+PSGODN(2.1)
- SET PSGRMVT=$PIECE(PSGODN(2.1),U,2)
- SET PSGRMV=$PIECE(PSGODN(2.1),U,3)
- SET PSGRF=$PIECE(PSGODN(2.1),U,4)
- +43 SET PSGSI=PSGODN(6)
- +44 ; The naked reference below refers to the full reference inside indirection to ^PS(55,PSGP,5,+PSGORD, or ^PS(55,PSGP,"IV",+PSGORD, or ^PS(53.1,+PSGORD
- +45 SET PSGODN(3)=0
- FOR Q=0:0
- SET Q=$ORDER(@(F_"3,"_Q_")"))
- if 'Q
- QUIT
- IF $DATA(^(Q,0))
- SET PSGODN(3,Q)=^(0)
- SET PSGODN(3)=PSGODN(3)+1
- SET ^PS(53.45,PSJSYSP,1,Q,0)=^(0)
- +46 ;S:PSGODN(12)>0 ^PS(53.45,PSJSYSP,4,0)="^53.4504" S:PSGODN(3)>0 ^PS(53.45,PSJSYSP,1,0)="^53.4501"
- +47 if PSGODN(3)>0
- SET ^PS(53.45,PSJSYSP,1,0)="^53.4501"
- +48 ; The naked reference below refers to the full reference inside indirection to ^PS(55,PSGP,5,+PSGORD, or ^PS(55,PSGP,"IV",+PSGORD, or ^PS(53.1,+PSGORD
- +49 ;338
- +50 NEW PSGK5345
- SET PSGK5345=0
- +51 SET (PSGODN(1),Q)=0
- FOR
- SET Q=$ORDER(@(F_"1,"_Q_")"))
- if 'Q
- QUIT
- SET ND=$GET(^(Q,0))
- IF ND
- Begin DoDot:1
- +52 IF '$PIECE(ND,"^",3)
- IF 'PSGK5345
- SET PSGODN(1)=PSGODN(1)+1
- SET PSGODN(1,PSGODN(1))=$PIECE(ND,"^",1,2)
- SET ^PS(53.45,PSJSYSP,2,PSGODN(1),0)=^(0)
- +53 IF '$PIECE(ND,"^",3)
- IF PSGK5345
- SET PSGODN(1,PSGODN(1))=$PIECE(ND,"^",1,2)
- SET ^PS(53.45,PSJSYSP,2,PSGODN(1),0)=^(0)
- SET PSGODN(1)=PSGODN(1)+1
- SET PSGK5345=0
- KILL ^PS(53.45,PSJSYSP,2,PSGODN(1),0)
- +54 IF $PIECE(ND,"^",3)
- SET PSGODN(1)=PSGODN(1)+1
- KILL ^PS(53.45,PSJSYSP,2,PSGODN(1),0)
- SET PSGK5345=1
- End DoDot:1
- +55 KILL PSGK5345
- +56 SET PSGS0Y=$PIECE(PSGODN(2),"^",5)
- SET PSGS0XT=$PIECE(PSGODN(2),"^",6)
- SET PSGNESD=""
- SET PSGSCH=$PIECE(PSGODN(2),U)
- +57 ;PSJ*5*256
- +58 SET PSJOLDNM("ORD_SCHD")=PSGSCH
- +59 IF $$CHKSCHD^PSJMISC2(.PSJOLDNM)
- WRITE !!,"Order not copied."
- DO PAUSE^VALM1
- KILL PSJOLDNM
- GOTO ORIG
- +60 if $GET(PSJOLDNM("NEW_SCHD"))]""
- SET PSGSCH=PSJOLDNM("NEW_SCHD")
- KILL PSJOLDNM
- +61 SET PSGODF=1
- SET PSGNEDFD=$PIECE($$GTNEDFD^PSGOE7("U",+PSGPDRG),U)_"^^"_PSGST_"^"_PSGSCH
- +62 WRITE "."
- DO ^PSGNE3
- +63 ;*399-IND
- KILL PSGEFN,PSGOEEF,PSGOEE,PSGOEOS
- SET PSGEFN="1:14"
- FOR X=1:1:14
- SET PSGEFN(X)=""
- +64 SET PSGPDN=$$OINAME^PSJLMUTL(PSGPDRG)
- SET PSGOINST=""
- SET PSGSDN=$$ENDD^PSGMI(PSGNESD)_U_$$ENDTC^PSGMI(PSGNESD)
- SET PSGFDN=$$ENDD^PSGMI(PSGNEFD)_U_$$ENDTC^PSGMI(PSGNEFD)
- +65 SET PSGAT=PSGS0Y
- SET PSGEBN=DUZ
- SET PSGLIN=$$ENDD^PSGMI(PSGDT)_U_$$ENDTC^PSGMI(PSGDT)
- SET PSGEBN=$$ENNPN^PSGMI(DUZ)
- SET PSGSTAT=$SELECT(PSGOEAV:"ACTIVE",1:"NON-VERIFIED")
- +66 WRITE "."
- DO CHK^PSGOEV("^^"_PSGMR_"^^^^"_PSGST,PSGPDRG_U_PSGDO,PSGSCH_U_PSGNESD_"^^"_PSGNEFD)
- +67 IF $GET(PSGSCH)]""
- Begin DoDot:1
- +68 NEW X
- SET X=PSGSCH
- NEW SWD,SDW,XABB,QX
- DO ENOS^PSGS0
- IF $GET(X)=""!$GET(PSJNSS)
- SET CHK=1
- KILL PSJNSS
- QUIT
- +69 IF $GET(PSGAT)=""
- IF $GET(PSGS0Y)
- SET PSGAT=PSGS0Y
- +70 IF $GET(PSGAT)
- IF ($GET(PSGS0Y)="")
- SET PSGS0Y=PSGAT
- +71 IF $GET(PSGS0XT)="D"
- IF $GET(PSGS0Y)=""
- SET CHK=1
- Begin DoDot:2
- +72 WRITE !
- KILL DIR
- SET DIR(0)="FOA"
- SET DIR("A")=" WARNING - Admin times are required for DAY OF WEEK schedules "
- DO ^DIR
- KILL DIR
- End DoDot:2
- KILL PSJNSS
- End DoDot:1
- +73 SET PSGSD=PSGNESD
- SET PSGFD=PSGNEFD
- +74 KILL PSJACEPT
- SET VALMBCK="Q"
- if $DATA(Y)
- DO EN^VALM("PSJU LM ACCEPT")
- +75 IF $GET(PSJACEPT)=1
- DO OC
- if $DATA(PSGORQF)
- SET PSJACEPT=0
- if $GET(PSJACEPT)=1
- SET VALMBCK=""
- SET PSJNOO=$$ENNOO^PSJUTL5("N")
- +76 ;PSJCOFLG set in PSODGAL1 for allergies
- IF '$GET(PSJACEPT)!($GET(PSJNOO)<0)
- if '$GET(PSJCOFLG)
- WRITE !!,"Order not copied."
- if '$GET(PSJCOFLG)
- DO PAUSE^VALM1
- GOTO ORIG
- +77 SET PSGNESD=PSGSD
- SET PSGNEFD=PSGFD
- +78 KILL PSGOEE
- DO ^PSGOETO
- SET PSJORD=PSGORD
- IF PSGOEAV
- Begin DoDot:1
- +79 IF '$DATA(PSGOEE)
- IF +PSJSYSU=3
- DO EN^PSGPEN(PSGORD)
- +80 ;; START NCC REMEDIATION >> 327*RJS
- +81 IF +$GET(PSGCOPY)!(+$GET(PSGEDT))
- Begin DoDot:2
- +82 IF CLOZFLG
- Begin DoDot:3
- +83 IF $DATA(^TMP($JOB,"PSGCLOZ",DFN,+$GET(PSJORD),"SAND"))
- Begin DoDot:4
- +84 SET DIE="^PS(55,"_DFN_",5,"
- SET DA=+PSJORD
- SET DA(1)=DFN
- SET DR="301////"_^TMP($JOB,"PSGCLOZ",DFN,+PSJORD,"SAND")
- DO ^DIE
- End DoDot:4
- KILL ^TMP($JOB,"PSGCLOZ",DFN,+PSJORD,"SAND")
- +85 NEW PSGDN
- SET PSGDN=$PIECE(CLOZFLG,U,2)
- +86 DO PSJFILE^PSJCLOZ(DFN)
- DO INPSND^YSCLTST5
- if $DATA(^TMP($JOB,"CLOZFLG",DFN))
- KILL ^TMP($JOB,"CLOZFLG",DFN)
- End DoDot:3
- End DoDot:2
- +87 ;; END NCC REMEDIATION >> 327*RJS
- +88 ;RTC 178789 Store allergy if auto vf is on
- DO SETOC^PSJNEWOC(PSGORD)
- End DoDot:1
- +89 DO GETUD^PSJLMGUD(PSGP,PSGORD)
- NEW PSGOEEF
- SET PSGOEEF=0
- DO ENSFE^PSGOEE0(PSGP,PSGORD)
- DO ^PSGOE1
- DO EN^VALM("PSJ LM UD ACTION")
- +90 ;RTC 178789 - store allery if not verified the newly copied order
- +91 IF ($GET(PSGORD)["P")
- IF ($PIECE($GET(^PS(53.1,+PSGORD,0)),U,9)="N")
- IF ($GET(PSJOCFG)="COPY UD")
- DO SETOC^PSJNEWOC(PSGORD)
- +92 ;
- +93 SET PSGCANFL=0
- SET (PSGORD,PSJORD)=OLDON
- WRITE !!,"You are finished with the new order.",!,"The following ACTION prompt is for the original order."
- +94 KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- ORIG ;Redisplay original order
- +1 DO GETUD^PSJLMGUD(PSGP,OLDON)
- DO INIT^PSJLMUDE(PSGP,OLDON)
- DONE ;
- +1 KILL %,%H,%I,DA,F,N,PSGODN,PSGODF,PSGS0XT,PSGS0Y,PSGNESD,PSGTOL,PSGTOO,PSGUOW,X,Y,^PS(53.45,PSJSYSP,1),^PS(53.45,PSJSYSP,2)
- +2 KILL PSGPR,PSGMR,PSGSM,PSGHSM,PSGST,PSGPDRG,PSGDO,PSGNEDFD,PSGSCH,PSGNEFD
- +3 QUIT
- +4 ;
- CH ;
- +1 WRITE !!?2,"Answer 'YES' to have a new, non-verified order created for this patient,",!,"using the information from this order. (The START and STOP dates will be",!,"recalculated.) Enter 'NO' (or '^') to stop now."
- QUIT
- +2 ;
- WH ;
- +1 WRITE !!?2,"Answer 'YES' to take action on this new order. Enter 'NO' (or '^') to return",!,"to the original order now."
- QUIT
- +2 ;
- OC ;Perform order checks
- +1 NEW PSJDD,X,PSJALLGY
- +2 ;*286 - Order checks on current dispense drugs
- +3 FOR X=0:0
- SET X=$ORDER(^PS(53.45,PSJSYSP,2,X))
- if 'X
- QUIT
- Begin DoDot:1
- +4 SET PSJDD=$GET(^PS(53.45,PSJSYSP,2,X,0))
- +5 IF +PSJDD
- SET PSJALLGY(+PSJDD)=""
- End DoDot:1
- +6 ;S X=+$O(PSGODN(1,0)) Q:'X S PSJDD=+$G(PSGODN(1,X)) Q:'PSJDD
- +7 SET PSJDD=+$ORDER(PSJALLGY(0))
- if 'PSJDD
- QUIT
- +8 DO FULL^VALM1
- +9 ;; START NCC REMEDIATION >> 327*RJS FOR TOTAL DAILY DOSE
- +10 IF CLOZFLG
- SET ANQX=0
- DO TDD^PSJCLOZ
- +11 if $GET(PSGORQF)
- QUIT
- +12 ;/RJS Begin PSJ*5.0*327 modification FOR ORDER CHECKS
- +13 SET PSJDD=+$ORDER(PSJALLGY(0))
- if 'PSJDD
- QUIT
- +14 DO FULL^VALM1
- +15 DO ENDDC^PSGSICHK($GET(PSGP),PSJDD)
- if $GET(PSGORQF)
- QUIT
- +16 DO IN^PSJOCDS($GET(PSGORD),"UD",PSJDD)
- if $GET(PSGORQF)
- QUIT
- +17 DO ORD^PSJCLOZ
- +18 QUIT
