- PSXDRPT ;BIR/WPB-Duplicate Rx Report ;09/09/98 6:46 AM
- ;;2.0;CMOP;**18,38**;11 Apr 97
- ALRT S ST=$$KSP^XUPARAM("INST")
- ;N X,Y S X=ST,DIC=4,DIC(0)="MNZ" S:$D(^PSX(552,"D",X)) X=$E(X,2,99) D ^DIC S SITE=$S($G(Y)]"":$P(Y,"^",2),1:"UNKNOWN") K X,Y,DIC ;****DOD L1
- N X,Y S X=ST,AGNCY="VASTANUM" S:$D(^PSX(552,"D",X)) X=$E(X,2,99),AGNCY="DMIS" S SITE=$$IEN^XUMF(4,AGNCY,X),SITE=$S($G(SITE)]"":$$NAME^XUAF4(SITE),1:"UNKNOWN") K X,Y,AGNCY ;****DOD L1
- S LN=$L(SITE),LEN=((80-LN)/2)+1,XQAKILL=0
- I '$D(^PSX(552.3,"AD")) W !,"There are no duplicate Rx's in the file!" G EXIT
- S %ZIS="Q" D ^%ZIS G EXIT:POP
- I $D(IO("Q")) D Q
- .S ZTRTN="STRT^PSXDRPT",ZTSAVE("LEN")="",ZTSAVE("SITE")="",ZTDESC="CMOP Duplicate Rx Report" D ^%ZTLOAD,HOME^%ZIS K IO("Q") Q
- ;Called by Taskman to run Duplicate Rx report
- STRT I '$D(^PSX(552.3,"AD")) W !,"There are no duplicate Rx's in the file!" G EXIT
- D HDR,EN
- Q
- HDR U IO W @IOF
- W !,?30,"Duplicate Rx Report",!,?LEN,SITE,!
- W !,"Rx #",?16,"Query #",?27,"Completed Time",?44,"Orig Qry",?56,"Orig Completed Time",!
- F I=0:1:79 W "-"
- S LCNT=7
- Q
- EN S (CNT,XX)=0 F S XX=$O(^PSX(552.3,"AD",XX)) Q:XX'>0 G:$G(STOP) EXIT S LAST=XX D
- .I $P(^PSX(552.3,XX,0),"|",1)["ZMP" S QRY1="MAN" D
- ..S RX=$P(^PSX(552.3,XX,0),"|",3),BATREF=$P(^PSX(552.3,XX,0),"|",2),C1=$P(^PSX(552.3,XX,0),"|",7),C2=$P($$FMTE^XLFDT(C1,"2S"),":",1,2)
- ..S P5521=$O(^PSX(552.1,"B",BATREF,"")),P5524=$O(^PSX(552.4,"B",P5521,"")),PRX=$O(^PSX(552.4,P5524,1,"B",RX,""))
- ..I $P(^PSX(552.4,P5524,1,PRX,0),"^",2)'="" S QRY2="MAN",CMDT=$P($G(^PSX(552.4,P5524,1,PRX,0)),"^",9) S CNT=CNT+1 D
- ...W !,RX,?16,$J(QRY1,7),?27,C2,?44,$J(QRY2,8),?56,$P($$FMTE^XLFDT(CMDT,"2S"),":",1,2) S LCNT=LCNT+1
- ..I ($G(LCNT)>22&($G(IOST)["C-")) S DIR(0)="E" D ^DIR K DIR S:$G(Y)'=1 STOP=1 Q:$G(STOP) D HDR
- ..I ($G(LCNT)>60&($G(IOST)'["C-")) D HDR
- ..K RX,BAT,BATREF,P5521,P5524,PRX,QRY2,CMDT,C2,C1
- .I $G(^PSX(552.3,XX,0))["QRD|" S QRY1=$P(^PSX(552.3,XX,0),"|",5),PSXTS=$P(^PSX(552.3,XX,0),"|",2) D TSIN^PSXUTL S QRYTM=PSXFM K PSXTS,PSXFM
- .I $G(^PSX(552.3,XX,0))["NTE|99" D
- ..S RX=$P($P(^PSX(552.3,XX,0),"\",1),"|",4),BAT=$P(^PSX(552.3,XX,0),"\F\",6),BATREF=$P(BAT,"-",1,2),C1=$P(^PSX(552.3,XX,0),"\",5),C2=$E(C1,5,6)_"/"_$E(C1,7,8)_"/"_$E(C1,3,4)_"@"_$E(C1,9,10)_":"_$E(C1,11,12)
- ..S P5521=$O(^PSX(552.1,"B",BATREF,"")),P5524=$O(^PSX(552.4,"B",P5521,"")),PRX=$O(^PSX(552.4,P5524,1,"B",RX,""))
- ..I $P(^PSX(552.4,P5524,1,PRX,0),"^",2)'="" S QRY2=$P($G(^PSX(552.4,P5524,1,PRX,0)),"^",8),CMDT=$P($G(^PSX(552.4,P5524,1,PRX,0)),"^",9) S CNT=CNT+1 D
- ...W !,RX,?16,$J($G(QRY1),7),?27,C2,?44,$J(QRY2,8),?56,$P($$FMTE^XLFDT(CMDT,"2S"),":",1,2) S LCNT=LCNT+1
- ..I ($G(LCNT)>22&($G(IOST)["C-")) S DIR(0)="E" D ^DIR K DIR S:$G(Y)'=1 STOP=1 Q:$G(STOP) D HDR
- ..I ($G(LCNT)>60&($G(IOST)'["C-")) D HDR
- .K RX,BAT,BATREF,P5521,P5524,PRX,QRY2,CMDT,C2,C1
- I IOST'["C-" D ^%ZISC G EXIT
- ASK S DIR(0)="Y",DIR("A")="Delete these Rx's",DIR("B")="YES",DIR("??")="Yes - deletes the duplicate Rx's from the CMOP Release file.",DIR("??",1)="No - Will not delete the duplicate Rx's from the CMOP Release file."
- D ^DIR K DIR G:($G(Y)=1) DEL
- EXIT K XX,CNT,QRY1,QRYTM,LEN,ST,SITE,LN,I,LCNT,LINE,DIR,X,Y,STOP
- S:$D(ZTQUEUED) ZTREQ="@" Q
- DEL S ZX=0,DIE="^PSX(552.3,",DR="1////1" F S ZX=$O(^PSX(552.3,"AD",ZX)) Q:ZX>$G(LAST)!(ZX'>0) L +^PSX(552.3,ZX):600 Q:'$T S DA=ZX D ^DIE L -^PSX(552.3,ZX) K DA
- K ZX,LAST,DA,DIE,DR
- G EXIT
- RESET S CC=0,DIE="^PSX(552.3,",DR="1////2" F S CC=$O(^PSX(552.3,"AF",CC)) Q:CC'>0 L +^PSX(552.3,CC) S DA=CC D ^DIE L -^PSX(552.3,CC) K DA
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXDRPT 3564 printed Jan 18, 2025@02:45:23 Page 2
- PSXDRPT ;BIR/WPB-Duplicate Rx Report ;09/09/98 6:46 AM
- +1 ;;2.0;CMOP;**18,38**;11 Apr 97
- ALRT SET ST=$$KSP^XUPARAM("INST")
- +1 ;N X,Y S X=ST,DIC=4,DIC(0)="MNZ" S:$D(^PSX(552,"D",X)) X=$E(X,2,99) D ^DIC S SITE=$S($G(Y)]"":$P(Y,"^",2),1:"UNKNOWN") K X,Y,DIC ;****DOD L1
- +2 ;****DOD L1
- NEW X,Y
- SET X=ST
- SET AGNCY="VASTANUM"
- if $DATA(^PSX(552,"D",X))
- SET X=$EXTRACT(X,2,99)
- SET AGNCY="DMIS"
- SET SITE=$$IEN^XUMF(4,AGNCY,X)
- SET SITE=$SELECT($GET(SITE)]"":$$NAME^XUAF4(SITE),1:"UNKNOWN")
- KILL X,Y,AGNCY
- +3 SET LN=$LENGTH(SITE)
- SET LEN=((80-LN)/2)+1
- SET XQAKILL=0
- +4 IF '$DATA(^PSX(552.3,"AD"))
- WRITE !,"There are no duplicate Rx's in the file!"
- GOTO EXIT
- +5 SET %ZIS="Q"
- DO ^%ZIS
- if POP
- GOTO EXIT
- +6 IF $DATA(IO("Q"))
- Begin DoDot:1
- +7 SET ZTRTN="STRT^PSXDRPT"
- SET ZTSAVE("LEN")=""
- SET ZTSAVE("SITE")=""
- SET ZTDESC="CMOP Duplicate Rx Report"
- DO ^%ZTLOAD
- DO HOME^%ZIS
- KILL IO("Q")
- QUIT
- End DoDot:1
- QUIT
- +8 ;Called by Taskman to run Duplicate Rx report
- STRT IF '$DATA(^PSX(552.3,"AD"))
- WRITE !,"There are no duplicate Rx's in the file!"
- GOTO EXIT
- +1 DO HDR
- DO EN
- +2 QUIT
- HDR USE IO
- WRITE @IOF
- +1 WRITE !,?30,"Duplicate Rx Report",!,?LEN,SITE,!
- +2 WRITE !,"Rx #",?16,"Query #",?27,"Completed Time",?44,"Orig Qry",?56,"Orig Completed Time",!
- +3 FOR I=0:1:79
- WRITE "-"
- +4 SET LCNT=7
- +5 QUIT
- EN SET (CNT,XX)=0
- FOR
- SET XX=$ORDER(^PSX(552.3,"AD",XX))
- if XX'>0
- QUIT
- if $GET(STOP)
- GOTO EXIT
- SET LAST=XX
- Begin DoDot:1
- +1 IF $PIECE(^PSX(552.3,XX,0),"|",1)["ZMP"
- SET QRY1="MAN"
- Begin DoDot:2
- +2 SET RX=$PIECE(^PSX(552.3,XX,0),"|",3)
- SET BATREF=$PIECE(^PSX(552.3,XX,0),"|",2)
- SET C1=$PIECE(^PSX(552.3,XX,0),"|",7)
- SET C2=$PIECE($$FMTE^XLFDT(C1,"2S"),":",1,2)
- +3 SET P5521=$ORDER(^PSX(552.1,"B",BATREF,""))
- SET P5524=$ORDER(^PSX(552.4,"B",P5521,""))
- SET PRX=$ORDER(^PSX(552.4,P5524,1,"B",RX,""))
- +4 IF $PIECE(^PSX(552.4,P5524,1,PRX,0),"^",2)'=""
- SET QRY2="MAN"
- SET CMDT=$PIECE($GET(^PSX(552.4,P5524,1,PRX,0)),"^",9)
- SET CNT=CNT+1
- Begin DoDot:3
- +5 WRITE !,RX,?16,$JUSTIFY(QRY1,7),?27,C2,?44,$JUSTIFY(QRY2,8),?56,$PIECE($$FMTE^XLFDT(CMDT,"2S"),":",1,2)
- SET LCNT=LCNT+1
- End DoDot:3
- +6 IF ($GET(LCNT)>22&($GET(IOST)["C-"))
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- if $GET(Y)'=1
- SET STOP=1
- if $GET(STOP)
- QUIT
- DO HDR
- +7 IF ($GET(LCNT)>60&($GET(IOST)'["C-"))
- DO HDR
- +8 KILL RX,BAT,BATREF,P5521,P5524,PRX,QRY2,CMDT,C2,C1
- End DoDot:2
- +9 IF $GET(^PSX(552.3,XX,0))["QRD|"
- SET QRY1=$PIECE(^PSX(552.3,XX,0),"|",5)
- SET PSXTS=$PIECE(^PSX(552.3,XX,0),"|",2)
- DO TSIN^PSXUTL
- SET QRYTM=PSXFM
- KILL PSXTS,PSXFM
- +10 IF $GET(^PSX(552.3,XX,0))["NTE|99"
- Begin DoDot:2
- +11 SET RX=$PIECE($PIECE(^PSX(552.3,XX,0),"\",1),"|",4)
- SET BAT=$PIECE(^PSX(552.3,XX,0),"\F\",6)
- SET BATREF=$PIECE(BAT,"-",1,2)
- SET C1=$PIECE(^PSX(552.3,XX,0),"\",5)
- SET C2=$EXTRACT(C1,5,6)_"/"_$EXTRACT(C1,7,8)_"/"_$EXTRACT(C1,3,4)_"@"_$EXTRACT(C1,9,10)_":"_$EXTRACT(C1,11,12)
- +12 SET P5521=$ORDER(^PSX(552.1,"B",BATREF,""))
- SET P5524=$ORDER(^PSX(552.4,"B",P5521,""))
- SET PRX=$ORDER(^PSX(552.4,P5524,1,"B",RX,""))
- +13 IF $PIECE(^PSX(552.4,P5524,1,PRX,0),"^",2)'=""
- SET QRY2=$PIECE($GET(^PSX(552.4,P5524,1,PRX,0)),"^",8)
- SET CMDT=$PIECE($GET(^PSX(552.4,P5524,1,PRX,0)),"^",9)
- SET CNT=CNT+1
- Begin DoDot:3
- +14 WRITE !,RX,?16,$JUSTIFY($GET(QRY1),7),?27,C2,?44,$JUSTIFY(QRY2,8),?56,$PIECE($$FMTE^XLFDT(CMDT,"2S"),":",1,2)
- SET LCNT=LCNT+1
- End DoDot:3
- +15 IF ($GET(LCNT)>22&($GET(IOST)["C-"))
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- if $GET(Y)'=1
- SET STOP=1
- if $GET(STOP)
- QUIT
- DO HDR
- +16 IF ($GET(LCNT)>60&($GET(IOST)'["C-"))
- DO HDR
- End DoDot:2
- +17 KILL RX,BAT,BATREF,P5521,P5524,PRX,QRY2,CMDT,C2,C1
- End DoDot:1
- +18 IF IOST'["C-"
- DO ^%ZISC
- GOTO EXIT
- ASK SET DIR(0)="Y"
- SET DIR("A")="Delete these Rx's"
- SET DIR("B")="YES"
- SET DIR("??")="Yes - deletes the duplicate Rx's from the CMOP Release file."
- SET DIR("??",1)="No - Will not delete the duplicate Rx's from the CMOP Release file."
- +1 DO ^DIR
- KILL DIR
- if ($GET(Y)=1)
- GOTO DEL
- EXIT KILL XX,CNT,QRY1,QRYTM,LEN,ST,SITE,LN,I,LCNT,LINE,DIR,X,Y,STOP
- +1 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- QUIT
- DEL SET ZX=0
- SET DIE="^PSX(552.3,"
- SET DR="1////1"
- FOR
- SET ZX=$ORDER(^PSX(552.3,"AD",ZX))
- if ZX>$GET(LAST)!(ZX'>0)
- QUIT
- LOCK +^PSX(552.3,ZX):600
- if '$TEST
- QUIT
- SET DA=ZX
- DO ^DIE
- LOCK -^PSX(552.3,ZX)
- KILL DA
- +1 KILL ZX,LAST,DA,DIE,DR
- +2 GOTO EXIT
- RESET SET CC=0
- SET DIE="^PSX(552.3,"
- SET DR="1////2"
- FOR
- SET CC=$ORDER(^PSX(552.3,"AF",CC))
- if CC'>0
- QUIT
- LOCK +^PSX(552.3,CC)
- SET DA=CC
- DO ^DIE
- LOCK -^PSX(552.3,CC)
- KILL DA
- +1 QUIT