- PSSPOIM1 ;BIR/RTR,WRT-Manual create of Orderable Item continued ;05-Jun-2013 22:13;PLS
- ;;1.0;PHARMACY DATA MANAGEMENT;**29,38,47,141,1015**;9/30/97;Build 62
- ;
- ;Modified - IHS/MSC/PLS - 06/05/13 - Line IMMUN+2
- CHK S PSNO=0 I $G(PSMAN) W !!,"Matching ",PSNAME,!," to",!,SPHOLD," ",$P($G(^PS(50.606,+DOSEPTR,0)),"^"),!
- I '$G(PSMAN) S PSMC=$P($G(^PS(50.7,PSSP,0)),"^") W !!,"Matching ",PSNAME,!," to",!,PSMC," ",$P($G(^PS(50.606,+$P(^PS(50.7,PSSP,0),"^",2),0)),"^"),!
- K DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="Is this OK" D ^DIR
- K PSMAN S:Y=0 PSNO=1 I Y'=1,'PSNO S PSOUT=1
- Q
- END K ^TMP($J,"PSSOO"),PSSSSS,PSCREATE,^TMP("PSSLOOP",$J)
- K AAA,ANS,APLU,COMM,DA,DIC,DIE,DOSEFORM,DOSEFV,DOSEPTR,DR,FFF,MATCH,NEWSP,NODE,NOFLAG,OTH,POINT,PSCNT,PSIEN,PSMAN,PSMC,PSNAME,PSNO,PSSP,PSND,PSOUT,SPHOLD,SPR,TMPTR,TT,VAGEN,X,Y,ZZ,PSOOOUT,PSXDATE,PSXADATE,PSXSDATE,AAAAA,BBBBB,ZXX,PSXDDATE Q
- MESS W !!,"This option enables you to match Dispense Drugs to an entry in the Pharmacy",!,"Orderable Item file, or create a new Pharmacy Orderable Item entry for a",!,"Dispense Drug.",! Q
- MESSZ S ^TMP("PSSLOOP",$J,DUZ)="" W !!,"This option is for matching IV Additives, IV Solutions, and all Dispense Drugs",!,"marked with an I, O, or U in the Application Packages' Use field to an",!,"Orderable Item."
- W !,"You will need to keep accessing this option until all drugs are matched.",!,"A check will be done every time this option is exited to see if the matching",!,"process is complete.",!!
- K DIR S DIR(0)="E" D ^DIR K DIR I X["^"!($D(DTOUT)) S PSOUT=1
- Q
- CHECK W !!!,"Checking Drug files, please wait..."
- S X1=DT,X2=-365 D C^%DTC S PSZXDATE=X,DONEFLAG=1
- F FFFF=0:0 S FFFF=$O(^PSDRUG(FFFF)) Q:'FFFF!('DONEFLAG) S QQNM=$P($G(^PSDRUG(FFFF,0)),"^") I QQNM'="",$D(^PSDRUG("B",QQNM)) D I ZZG I USAGE["O"!(USAGE["I")!(USAGE["U") I '$P($G(^PSDRUG(FFFF,2)),"^") S DONEFLAG=0
- .S USAGE=$P($G(^PSDRUG(FFFF,2)),"^",3)
- .S ZZG=1 S PSZZDATE=+$P($G(^PSDRUG(FFFF,"I")),"^") I PSZZDATE,PSZZDATE<PSZXDATE S ZZG=0
- I DONEFLAG=1 D
- .F QQQ=0:0 S QQQ=$O(^PS(52.6,QQQ)) Q:'QQQ!('DONEFLAG) S PSZNAME=$P($G(^PS(52.6,QQQ,0)),"^") I PSZNAME'="",$D(^PS(52.6,"B",PSZNAME)),$P($G(^PS(52.6,QQQ,0)),"^",2),'$P($G(^(0)),"^",11) D I ZZG S DONEFLAG=0
- ..S ZZG=1 S PSZZDATE=+$P($G(^PS(52.6,QQQ,"I")),"^") I PSZZDATE,PSZZDATE<PSZXDATE S ZZG=0
- .I DONEFLAG F QQQ=0:0 S QQQ=$O(^PS(52.7,QQQ)) Q:'QQQ!('DONEFLAG) S PSZNAME=$P($G(^PS(52.7,QQQ,0)),"^") I PSZNAME'="",$D(^PS(52.7,"B",PSZNAME)),$P($G(^PS(52.7,QQQ,0)),"^",2),'$P($G(^(0)),"^",11) D I ZZG S DONEFLAG=0
- ..S ZZG=1 S PSZZDATE=+$P($G(^PS(52.7,QQQ,"I")),"^") I PSZZDATE,PSZZDATE<PSZXDATE S ZZG=0
- MAIL I DONEFLAG W !!!,?3,"You are finished matching to the Orderable Item File!",!!,"A clean-up job is being queued now, and when it is finished, you will"
- I W !,"receive a mail message informing you of its completion.",! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
- I $G(DONEFLAG) S PSSOMAIL=1,PSOUDUZ=DUZ S ZTRTN="DATE^PSSPOIM1",ZTIO="",ZTDTH=$H,ZTDESC="ORDERABLE ITEM CLEAN UP",ZTSAVE("DUZ")="",ZTSAVE("PSSOMAIL")="" D ^%ZTLOAD
- I 'DONEFLAG W $C(7),$C(7),!!?5,"There are still Drugs not matched, you will need to come back",!?5,"and continue matching Drugs!",! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
- K DONEFLAG,QQQ,QQNM,PSZZDATE,PSZXDATE,ZZG,USAGE,FFFF,PSZNAME Q
- OTHER W @IOF W !,"There are other Dispense Drugs with the same VA Generic Name and same Dose",!,"Form already matched to orderable items. Choose a number to match, or enter",!,"'^' to enter a new one.",!!?6,"Disp. drug -> ",PSNAME,! Q
- EN(PSVAR) ;
- W !?3,"Now editing Orderable Item:",!?3,$P(^PS(50.7,PSVAR,0),"^")," ",$P($G(^PS(50.606,+$P(^(0),"^",2),0)),"^")
- W ! K DIE N MFLG S PSBEFORE=$P(^PS(50.7,PSVAR,0),"^",4),PSAFTER=0,PSINORDE=""
- S PSSOTH=$P($G(^PS(59.7,1,40.2)),"^"),DIE="^PS(50.7,",DR="5;6;.04;.05;.06;.07;.08;7;S:'$G(PSSOTH) Y=""@1"";7.1;@1",DA=PSVAR
- D ^DIE S PSAFTER=$P(^PS(50.7,PSVAR,0),"^",4) K DIE,PSSOTH
- S:PSBEFORE&('PSAFTER) PSINORDE="D" S:PSAFTER PSINORDE="I"
- I PSINORDE'="" D REST^PSSPOIDT(PSVAR)
- K PSBEFORE,PSAFTER,PSINORDE
- IMMUN ;PSS*1*141 FOR 'IMMUNIZATIONS DOCUMENTATION BY BCMA'
- I $O(^PSDRUG("AOC",PSVAR,"IM000"))'["IM" G SYN ;ASK WHEN APPROPRIATE
- ;W ! S DIE="^PS(50.7,",DA=PSVAR,DR=9 D ^DIE K DIE ;IHS/MSC/PLS - Commented out per IHS
- SYN W ! K DIC S:'$D(^PS(50.7,PSVAR,2,0)) ^PS(50.7,PSVAR,2,0)="^50.72^0^0" S DIC="^PS(50.7,"_PSVAR_",2,",DA(1)=PSVAR,DIC(0)="QEAMZL",DIC("A")="Select SYNONYM: ",DLAYGO=50.72 D ^DIC K DIC
- I Y<0!($D(DTOUT))!($D(DUOUT)) K:'$O(^PS(50.7,PSVAR,2,0)) ^PS(50.7,PSVAR,2,0) G FIN
- W ! S DA=+Y,DIE="^PS(50.7,"_PSVAR_",2,",DA(1)=PSVAR,DR=.01 D ^DIE K DIE G SYN
- FIN D EN^PSSPOIDT(PSVAR) I $G(PSVAR1) D EN2^PSSHL1(PSVAR,"MAD") G FINS
- D EN2^PSSHL1(PSVAR,"MUP")
- FINS K PSVAR,PSVAR1 Q
- ;
- DATE ;
- F ZZZ=0:0 S ZZZ=$O(^PS(50.7,ZZZ)) Q:'ZZZ S PSOTYPE=$P($G(^PS(50.7,ZZZ,0)),"^",3) D
- .I PSOTYPE,'$D(^PS(52.6,"AOI",ZZZ)),'$D(^PS(52.7,"AOI",ZZZ)),'$P($G(^PS(50.7,ZZZ,0)),"^",4) K DIE S DIE="^PS(50.7,",DA=ZZZ,DR=".04////"_DT D ^DIE K DIE Q
- .Q:PSOTYPE
- .D SUPP
- .I '$D(^PSDRUG("ASP",ZZZ)),'$P($G(^PS(50.7,ZZZ,0)),"^",4) K DIE S DIE="^PS(50.7,",DA=ZZZ,DR=".04////"_DT D ^DIE K DIE Q
- .D:'$P($G(^PS(50.7,ZZZ,0)),"^",4)
- ..S PSDFLAG=0 F WW=0:0 S WW=$O(^PSDRUG("ASP",ZZZ,WW)) Q:'WW!(PSDFLAG) S PSAPPL=$P($G(^PSDRUG(WW,2)),"^",3) I PSAPPL["I"!(PSAPPL["O")!(PSAPPL["U") S PSDFLAG=1
- ..I 'PSDFLAG K DIE S DIE="^PS(50.7,",DA=ZZZ,DR=".04////"_DT D ^DIE K DIE
- F ZZZ=0:0 S ZZZ=$O(^PS(52.7,ZZZ)) Q:'ZZZ S RRRR=$P($G(^PS(52.7,ZZZ,0)),"^",11) I RRRR,'$P($G(^PS(50.7,RRRR,0)),"^",3) K DIE S DA=ZZZ,DIE="^PS(52.7,",DR="9////"_"@" D ^DIE K DIE
- F ZZZ=0:0 S ZZZ=$O(^PS(52.6,ZZZ)) Q:'ZZZ S RRRR=$P($G(^PS(52.6,ZZZ,0)),"^",11) I RRRR,'$P($G(^PS(50.7,RRRR,0)),"^",3) K DIE S DA=ZZZ,DIE="^PS(52.6,",DR="15////"_"@" D ^DIE K DIE
- D:$G(PSCREATE) MAIL^PSSCREAT
- I '$G(PSSOMAIL) K PSOTYPE,DA,DIE,WW,RRRR,PSDFLAG,PSAPPL,GGG,HHH,ZZZZZ Q
- S PSOTEXT(1)="You have completed the matching process required for the installation of",PSOTEXT(2)="Outpatient V. 7.0 and Inpatient Medications V. 5.0!"
- S XMDUZ=.5,XMY(DUZ)="",XMTEXT="PSOTEXT(",XMSUB="Pharmacy Orderable Item File" D ^XMD
- S PSSITE=+$O(^PS(59.7,0)) S $P(^PS(59.7,PSSITE,80),"^",2)=3 K PSSITE
- D ^%ZISC K PSOTYPE,DA,DIE,WW,RRRR,PSDFLAG,PSAPPL,GGG,HHH,ZZZZZ,PSSOMAIL S:$D(ZTQUEUED) ZTREQ="@" Q
- RMES W !!,"This report takes a long time to first build the data to print, then to",!,"actually print the data. To avoid tying up a terminal for a long period of time,",!,"the report must be QUEUED to a printer."
- W !!,"This report must be QUEUED to a printer!"
- Q
- KMES W !!,"Due to the length of this report, and to avoid tying up a terminal for a long",!,"time, this report must be QUEUED to a printer!"
- Q
- SUPP ;Mark as supply
- N SSSUP,SSSIN,SSSAP,SSLOOP,SSSQUE,SSSQUEY,SSSQDATE,SLIP,SLDO,SLDP
- S (SSSQUE,SSSQUEY)=0 F SSLOOP=0:0 S SSLOOP=$O(^PSDRUG("ASP",ZZZ,SSLOOP)) Q:'SSLOOP!(SSSQUEY) D
- .I $P($G(^PSDRUG(SSLOOP,0)),"^",3)["S" S SSSAP=$P($G(^(2)),"^",3),SSSIN=$P($G(^("I")),"^") D
- ..I SSSAP["O"!(SSSAP["I")!(SSSAP["U") I 'SSSIN S $P(^PS(50.7,ZZZ,0),"^",9)=1 S (SSSQUEY,SSSQUE)=1 Q
- ..I SSSAP["O"!(SSSAP["I")!(SSSAP["U") I +SSSIN>DT S $P(^PS(50.7,ZZZ,0),"^",9)=1 S SSSQUE=1,SSSQDATE($E(SSSIN,1,7))=""
- I 'SSSQUEY,SSSQUE,$O(SSSQDATE(0)) F SLIP=0:0 S SLIP=$O(SSSQDATE(SLIP)) Q:'SLIP D
- .S ZTRTN="ENT^PSSPOIDT",ZTDESC="Supply update for Orderable Item",ZTIO="",ZTDTH=SLIP_.01 S SLDO=$G(PSSORDIT),SLDP=$G(PSSCROSS) S PSSORDIT=ZZZ,PSSCROSS=1 S ZTSAVE("PSSORDIT")="",ZTSAVE("PSSCROSS")="" D ^%ZTLOAD D
- ..S PSSORDIT=$G(SLDO) K:'PSSORDIT PSSORDIT
- ..S PSSCROSS=$G(SLDP) K:'PSSCROSS PSSCROSS
- PSSPOIM1 ;BIR/RTR,WRT-Manual create of Orderable Item continued ;05-Jun-2013 22:13;PLS
- +1 ;;1.0;PHARMACY DATA MANAGEMENT;**29,38,47,141,1015**;9/30/97;Build 62
- +2 ;
- +3 ;Modified - IHS/MSC/PLS - 06/05/13 - Line IMMUN+2
- CHK SET PSNO=0
- IF $GET(PSMAN)
- WRITE !!,"Matching ",PSNAME,!," to",!,SPHOLD," ",$PIECE($GET(^PS(50.606,+DOSEPTR,0)),"^"),!
- +1 IF '$GET(PSMAN)
- SET PSMC=$PIECE($GET(^PS(50.7,PSSP,0)),"^")
- WRITE !!,"Matching ",PSNAME,!," to",!,PSMC," ",$PIECE($GET(^PS(50.606,+$PIECE(^PS(50.7,PSSP,0),"^",2),0)),"^"),!
- +2 KILL DIR
- SET DIR(0)="Y"
- SET DIR("B")="YES"
- SET DIR("A")="Is this OK"
- DO ^DIR
- +3 KILL PSMAN
- IF Y=0
- SET PSNO=1
- IF Y'=1
- IF 'PSNO
- SET PSOUT=1
- +4 QUIT
- END KILL ^TMP($JOB,"PSSOO"),PSSSSS,PSCREATE,^TMP("PSSLOOP",$JOB)
- +1 KILL AAA,ANS,APLU,COMM,DA,DIC,DIE,DOSEFORM,DOSEFV,DOSEPTR,DR,FFF,MATCH,NEWSP,NODE,NOFLAG,OTH,POINT,PSCNT,PSIEN,PSMAN,PSMC,PSNAME,PSNO,PSSP,PSND,PSOUT,SPHOLD,SPR,TMPTR,TT,VAGEN,X,Y,ZZ,PSOOOUT,PSXDATE,PSXADATE,PSXSDATE,AAAAA,BBBBB,ZXX,PSXDDATE
- QUIT
- MESS WRITE !!,"This option enables you to match Dispense Drugs to an entry in the Pharmacy",!,"Orderable Item file, or create a new Pharmacy Orderable Item entry for a",!,"Dispense Drug.",!
- QUIT
- MESSZ SET ^TMP("PSSLOOP",$JOB,DUZ)=""
- WRITE !!,"This option is for matching IV Additives, IV Solutions, and all Dispense Drugs",!,"marked with an I, O, or U in the Application Packages' Use field to an",!,"Orderable Item."
- +1 WRITE !,"You will need to keep accessing this option until all drugs are matched.",!,"A check will be done every time this option is exited to see if the matching",!,"process is complete.",!!
- +2 KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- IF X["^"!($DATA(DTOUT))
- SET PSOUT=1
- +3 QUIT
- CHECK WRITE !!!,"Checking Drug files, please wait..."
- +1 SET X1=DT
- SET X2=-365
- DO C^%DTC
- SET PSZXDATE=X
- SET DONEFLAG=1
- +2 FOR FFFF=0:0
- SET FFFF=$ORDER(^PSDRUG(FFFF))
- IF 'FFFF!('DONEFLAG)
- QUIT
- SET QQNM=$PIECE($GET(^PSDRUG(FFFF,0)),"^")
- IF QQNM'=""
- IF $DATA(^PSDRUG("B",QQNM))
- Begin DoDot:1
- +3 SET USAGE=$PIECE($GET(^PSDRUG(FFFF,2)),"^",3)
- +4 SET ZZG=1
- SET PSZZDATE=+$PIECE($GET(^PSDRUG(FFFF,"I")),"^")
- IF PSZZDATE
- IF PSZZDATE<PSZXDATE
- SET ZZG=0
- End DoDot:1
- IF ZZG
- IF USAGE["O"!(USAGE["I")!(USAGE["U")
- IF '$PIECE($GET(^PSDRUG(FFFF,2)),"^")
- SET DONEFLAG=0
- +5 IF DONEFLAG=1
- Begin DoDot:1
- +6 FOR QQQ=0:0
- SET QQQ=$ORDER(^PS(52.6,QQQ))
- IF 'QQQ!('DONEFLAG)
- QUIT
- SET PSZNAME=$PIECE($GET(^PS(52.6,QQQ,0)),"^")
- IF PSZNAME'=""
- IF $DATA(^PS(52.6,"B",PSZNAME))
- IF $PIECE($GET(^PS(52.6,QQQ,0)),"^",2)
- IF '$PIECE($GET(^(0)),"^",11)
- Begin DoDot:2
- +7 SET ZZG=1
- SET PSZZDATE=+$PIECE($GET(^PS(52.6,QQQ,"I")),"^")
- IF PSZZDATE
- IF PSZZDATE<PSZXDATE
- SET ZZG=0
- End DoDot:2
- IF ZZG
- SET DONEFLAG=0
- +8 IF DONEFLAG
- FOR QQQ=0:0
- SET QQQ=$ORDER(^PS(52.7,QQQ))
- IF 'QQQ!('DONEFLAG)
- QUIT
- SET PSZNAME=$PIECE($GET(^PS(52.7,QQQ,0)),"^")
- IF PSZNAME'=""
- IF $DATA(^PS(52.7,"B",PSZNAME))
- IF $PIECE($GET(^PS(52.7,QQQ,0)),"^",2)
- IF '$PIECE($GET(^(0)),"^",11)
- Begin DoDot:2
- +9 SET ZZG=1
- SET PSZZDATE=+$PIECE($GET(^PS(52.7,QQQ,"I")),"^")
- IF PSZZDATE
- IF PSZZDATE<PSZXDATE
- SET ZZG=0
- End DoDot:2
- IF ZZG
- SET DONEFLAG=0
- End DoDot:1
- MAIL IF DONEFLAG
- WRITE !!!,?3,"You are finished matching to the Orderable Item File!",!!,"A clean-up job is being queued now, and when it is finished, you will"
- +1 IF $TEST
- WRITE !,"receive a mail message informing you of its completion.",!
- KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="Press Return to continue"
- DO ^DIR
- KILL DIR
- +2 IF $GET(DONEFLAG)
- SET PSSOMAIL=1
- SET PSOUDUZ=DUZ
- SET ZTRTN="DATE^PSSPOIM1"
- SET ZTIO=""
- SET ZTDTH=$HOROLOG
- SET ZTDESC="ORDERABLE ITEM CLEAN UP"
- SET ZTSAVE("DUZ")=""
- SET ZTSAVE("PSSOMAIL")=""
- DO ^%ZTLOAD
- +3 IF 'DONEFLAG
- WRITE $CHAR(7),$CHAR(7),!!?5,"There are still Drugs not matched, you will need to come back",!?5,"and continue matching Drugs!",!
- KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="Press Return to continue"
- DO ^DIR
- KILL DIR
- +4 KILL DONEFLAG,QQQ,QQNM,PSZZDATE,PSZXDATE,ZZG,USAGE,FFFF,PSZNAME
- QUIT
- OTHER WRITE @IOF
- WRITE !,"There are other Dispense Drugs with the same VA Generic Name and same Dose",!,"Form already matched to orderable items. Choose a number to match, or enter",!,"'^' to enter a new one.",!!?6,"Disp. drug -> ",PSNAME,!
- QUIT
- EN(PSVAR) ;
- +1 WRITE !?3,"Now editing Orderable Item:",!?3,$PIECE(^PS(50.7,PSVAR,0),"^")," ",$PIECE($GET(^PS(50.606,+$PIECE(^(0),"^",2),0)),"^")
- +2 WRITE !
- KILL DIE
- NEW MFLG
- SET PSBEFORE=$PIECE(^PS(50.7,PSVAR,0),"^",4)
- SET PSAFTER=0
- SET PSINORDE=""
- +3 SET PSSOTH=$PIECE($GET(^PS(59.7,1,40.2)),"^")
- SET DIE="^PS(50.7,"
- SET DR="5;6;.04;.05;.06;.07;.08;7;S:'$G(PSSOTH) Y=""@1"";7.1;@1"
- SET DA=PSVAR
- +4 DO ^DIE
- SET PSAFTER=$PIECE(^PS(50.7,PSVAR,0),"^",4)
- KILL DIE,PSSOTH
- +5 IF PSBEFORE&('PSAFTER)
- SET PSINORDE="D"
- IF PSAFTER
- SET PSINORDE="I"
- +6 IF PSINORDE'=""
- DO REST^PSSPOIDT(PSVAR)
- +7 KILL PSBEFORE,PSAFTER,PSINORDE
- IMMUN ;PSS*1*141 FOR 'IMMUNIZATIONS DOCUMENTATION BY BCMA'
- +1 ;ASK WHEN APPROPRIATE
- IF $ORDER(^PSDRUG("AOC",PSVAR,"IM000"))'["IM"
- GOTO SYN
- +2 ;W ! S DIE="^PS(50.7,",DA=PSVAR,DR=9 D ^DIE K DIE ;IHS/MSC/PLS - Commented out per IHS
- SYN WRITE !
- KILL DIC
- IF '$DATA(^PS(50.7,PSVAR,2,0))
- SET ^PS(50.7,PSVAR,2,0)="^50.72^0^0"
- SET DIC="^PS(50.7,"_PSVAR_",2,"
- SET DA(1)=PSVAR
- SET DIC(0)="QEAMZL"
- SET DIC("A")="Select SYNONYM: "
- SET DLAYGO=50.72
- DO ^DIC
- KILL DIC
- +1 IF Y<0!($DATA(DTOUT))!($DATA(DUOUT))
- IF '$ORDER(^PS(50.7,PSVAR,2,0))
- KILL ^PS(50.7,PSVAR,2,0)
- GOTO FIN
- +2 WRITE !
- SET DA=+Y
- SET DIE="^PS(50.7,"_PSVAR_",2,"
- SET DA(1)=PSVAR
- SET DR=.01
- DO ^DIE
- KILL DIE
- GOTO SYN
- FIN DO EN^PSSPOIDT(PSVAR)
- IF $GET(PSVAR1)
- DO EN2^PSSHL1(PSVAR,"MAD")
- GOTO FINS
- +1 DO EN2^PSSHL1(PSVAR,"MUP")
- FINS KILL PSVAR,PSVAR1
- QUIT
- +1 ;
- DATE ;
- +1 FOR ZZZ=0:0
- SET ZZZ=$ORDER(^PS(50.7,ZZZ))
- IF 'ZZZ
- QUIT
- SET PSOTYPE=$PIECE($GET(^PS(50.7,ZZZ,0)),"^",3)
- Begin DoDot:1
- +2 IF PSOTYPE
- IF '$DATA(^PS(52.6,"AOI",ZZZ))
- IF '$DATA(^PS(52.7,"AOI",ZZZ))
- IF '$PIECE($GET(^PS(50.7,ZZZ,0)),"^",4)
- KILL DIE
- SET DIE="^PS(50.7,"
- SET DA=ZZZ
- SET DR=".04////"_DT
- DO ^DIE
- KILL DIE
- QUIT
- +3 IF PSOTYPE
- QUIT
- +4 DO SUPP
- +5 IF '$DATA(^PSDRUG("ASP",ZZZ))
- IF '$PIECE($GET(^PS(50.7,ZZZ,0)),"^",4)
- KILL DIE
- SET DIE="^PS(50.7,"
- SET DA=ZZZ
- SET DR=".04////"_DT
- DO ^DIE
- KILL DIE
- QUIT
- +6 IF '$PIECE($GET(^PS(50.7,ZZZ,0)),"^",4)
- Begin DoDot:2
- +7 SET PSDFLAG=0
- FOR WW=0:0
- SET WW=$ORDER(^PSDRUG("ASP",ZZZ,WW))
- IF 'WW!(PSDFLAG)
- QUIT
- SET PSAPPL=$PIECE($GET(^PSDRUG(WW,2)),"^",3)
- IF PSAPPL["I"!(PSAPPL["O")!(PSAPPL["U")
- SET PSDFLAG=1
- +8 IF 'PSDFLAG
- KILL DIE
- SET DIE="^PS(50.7,"
- SET DA=ZZZ
- SET DR=".04////"_DT
- DO ^DIE
- KILL DIE
- End DoDot:2
- End DoDot:1
- +9 FOR ZZZ=0:0
- SET ZZZ=$ORDER(^PS(52.7,ZZZ))
- IF 'ZZZ
- QUIT
- SET RRRR=$PIECE($GET(^PS(52.7,ZZZ,0)),"^",11)
- IF RRRR
- IF '$PIECE($GET(^PS(50.7,RRRR,0)),"^",3)
- KILL DIE
- SET DA=ZZZ
- SET DIE="^PS(52.7,"
- SET DR="9////"_"@"
- DO ^DIE
- KILL DIE
- +10 FOR ZZZ=0:0
- SET ZZZ=$ORDER(^PS(52.6,ZZZ))
- IF 'ZZZ
- QUIT
- SET RRRR=$PIECE($GET(^PS(52.6,ZZZ,0)),"^",11)
- IF RRRR
- IF '$PIECE($GET(^PS(50.7,RRRR,0)),"^",3)
- KILL DIE
- SET DA=ZZZ
- SET DIE="^PS(52.6,"
- SET DR="15////"_"@"
- DO ^DIE
- KILL DIE
- +11 IF $GET(PSCREATE)
- DO MAIL^PSSCREAT
- +12 IF '$GET(PSSOMAIL)
- KILL PSOTYPE,DA,DIE,WW,RRRR,PSDFLAG,PSAPPL,GGG,HHH,ZZZZZ
- QUIT
- +13 SET PSOTEXT(1)="You have completed the matching process required for the installation of"
- SET PSOTEXT(2)="Outpatient V. 7.0 and Inpatient Medications V. 5.0!"
- +14 SET XMDUZ=.5
- SET XMY(DUZ)=""
- SET XMTEXT="PSOTEXT("
- SET XMSUB="Pharmacy Orderable Item File"
- DO ^XMD
- +15 SET PSSITE=+$ORDER(^PS(59.7,0))
- SET $PIECE(^PS(59.7,PSSITE,80),"^",2)=3
- KILL PSSITE
- +16 DO ^%ZISC
- KILL PSOTYPE,DA,DIE,WW,RRRR,PSDFLAG,PSAPPL,GGG,HHH,ZZZZZ,PSSOMAIL
- IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- QUIT
- RMES WRITE !!,"This report takes a long time to first build the data to print, then to",!,"actually print the data. To avoid tying up a terminal for a long period of time,",!,"the report must be QUEUED to a printer."
- +1 WRITE !!,"This report must be QUEUED to a printer!"
- +2 QUIT
- KMES WRITE !!,"Due to the length of this report, and to avoid tying up a terminal for a long",!,"time, this report must be QUEUED to a printer!"
- +1 QUIT
- SUPP ;Mark as supply
- +1 NEW SSSUP,SSSIN,SSSAP,SSLOOP,SSSQUE,SSSQUEY,SSSQDATE,SLIP,SLDO,SLDP
- +2 SET (SSSQUE,SSSQUEY)=0
- FOR SSLOOP=0:0
- SET SSLOOP=$ORDER(^PSDRUG("ASP",ZZZ,SSLOOP))
- IF 'SSLOOP!(SSSQUEY)
- QUIT
- Begin DoDot:1
- +3 IF $PIECE($GET(^PSDRUG(SSLOOP,0)),"^",3)["S"
- SET SSSAP=$PIECE($GET(^(2)),"^",3)
- SET SSSIN=$PIECE($GET(^("I")),"^")
- Begin DoDot:2
- +4 IF SSSAP["O"!(SSSAP["I")!(SSSAP["U")
- IF 'SSSIN
- SET $PIECE(^PS(50.7,ZZZ,0),"^",9)=1
- SET (SSSQUEY,SSSQUE)=1
- QUIT
- +5 IF SSSAP["O"!(SSSAP["I")!(SSSAP["U")
- IF +SSSIN>DT
- SET $PIECE(^PS(50.7,ZZZ,0),"^",9)=1
- SET SSSQUE=1
- SET SSSQDATE($EXTRACT(SSSIN,1,7))=""
- End DoDot:2
- End DoDot:1
- +6 IF 'SSSQUEY
- IF SSSQUE
- IF $ORDER(SSSQDATE(0))
- FOR SLIP=0:0
- SET SLIP=$ORDER(SSSQDATE(SLIP))
- IF 'SLIP
- QUIT
- Begin DoDot:1
- +7 SET ZTRTN="ENT^PSSPOIDT"
- SET ZTDESC="Supply update for Orderable Item"
- SET ZTIO=""
- SET ZTDTH=SLIP_.01
- SET SLDO=$GET(PSSORDIT)
- SET SLDP=$GET(PSSCROSS)
- SET PSSORDIT=ZZZ
- SET PSSCROSS=1
- SET ZTSAVE("PSSORDIT")=""
- SET ZTSAVE("PSSCROSS")=""
- DO ^%ZTLOAD
- Begin DoDot:2
- +8 SET PSSORDIT=$GET(SLDO)
- IF 'PSSORDIT
- KILL PSSORDIT
- +9 SET PSSCROSS=$GET(SLDP)
- IF 'PSSCROSS
- KILL PSSCROSS
- End DoDot:2
- End DoDot:1
