APSPPCCU ;IHS/CIA/DKM/PLS - Utilities for PCC Hook for Pharmacy Package ;30-Aug-2005 13:07;SM
;;7.0;IHS PHARMACY MODIFICATIONS;**1003**;DEC 11, 2003
; Search for bad PSRX-->VMED link
BADP2V ;EP
N PSRX,REF,VMED,CNT,F1
W "Searching for bad PSRX-->VMED links...",!!
S F1=$$ASK^CIAU("Repair bad links")
Q:'$L(F1)
R "Starting PSRX: ",PSRX,!!
Q:PSRX[U
S:PSRX PSRX=PSRX-1
S CNT=0
F S PSRX=$O(^PSRX(PSRX)) Q:'PSRX D
.S VMED=$G(^PSRX(PSRX,999999911)),REF=0
.D BADP2VX
.F S REF=$O(^PSRX(PSRX,1,REF)) Q:'REF D
..S VMED=$G(^PSRX(PSRX,1,REF,999999911))
..D BADP2VX
.W:$X !
W !!,"Bad links found: ",CNT,!!
Q
; Check VMED
BADP2VX ;EP
I VMED,'$D(^AUPNVMED(VMED)) D
.W $S($X:",",1:PSRX_": "),REF
.S CNT=CNT+1
.I F1 D
..N X
..S X=$$PROCESS^APSPPCC(PSRX,REF)
..W:X " ",$P(X,U,2),!
Q
; Search for bad VMED-->PSRX link
BADV2P ;EP
N VMED,CNT,F1
W "Searching for bad VMED-->PSRX link...",!!
S F1=$$ASK^CIAU("Remove orphaned VMED entries")
Q:'$L(F1)
R "Starting VMED: ",VMED,!!
Q:VMED[U
S:VMED VMED=VMED-1
S CNT=0
F S VMED=$O(^AUPNVMED(VMED)) Q:'VMED D:'$D(^PSRX("APCC",VMED))
.S CNT=CNT+1
.W VMED,!
.I F1 D
..N DIK,DA
..S DIK="^AUPNVMED(",DA=VMED
..D ^DIK
W !!,"Bad links found: ",CNT,!!
Q
; Search for scripts without VMED links
NOVMED ;EP
N PSRX,F1
W "Searching for Rx's w/o PCC linkage...",!!
S F1=$$ASK^CIAU("Create entries for unlinked Rx's")
Q:'$L(F1)
R "Starting PSRX: ",PSRX,!!
Q:PSRX[U
F S PSRX=$O(^PSRX(PSRX)) Q:'PSRX D
.S $X=1
.D CHECK(PSRX)
.I '$X,F1 D
..N X
..S X=$$PROCESS^APSPPCC(PSRX)
..W:X ?5,$P(X,U,2),!
Q
; Search message log for missing PCC links
MSG ;EP
W "Searching message log for missing PCC links...",!!
N I1,I2,I3,Z,F1,F2
S F1=$$ASK^CIAU("Purge linked messages")
S F2=$$ASK^CIAU("Reprocess unlinked Rx's")
S I3=$O(^XTMP("APSPPCC",$C(1)),-1)
F I1=0:0:I3 S I1=$O(^XTMP("APSPPCC",I1)) Q:'I1 D
.W *13,I1,?10
.F I2=0:0 S I2=$O(^XTMP("APSPPCC",I1,"MSG",I2)) Q:'I2 D Q:I2<0
..S Z=^XTMP("APSPPCC",I1,"MSG",I2)
..Q:$E(Z,1,3)'="ORC"
..S Z=$P(Z,"|",4)
..Q:$P(Z,U,2)'="PS"
..S Z=$P(Z,U)
..D:Z=+Z CHECK(Z)
..S:'$X I2=-1
.I F1,'I2 K ^XTMP("APSPPCC",I1)
.I F2,I2 D REP(I1)
W *13,?20,!!
Q
; Check VMED link for a script
CHECK(PSRX) ;EP
N REF,STA
S STA=+$G(^PSRX(PSRX,"STA"))
Q:STA=3!(STA=13)!(STA=16)
S REF=$O(^PSRX(PSRX,1,$C(1)),-1)
I REF D Q
.I $G(^PSRX(PSRX,1,REF,999999911)),$D(^AUPNVMED(^(999999911))) Q
.W:$P(^PSRX(PSRX,1,REF,0),U,18) PSRX,":",REF,!
I $G(^PSRX(PSRX,999999911)),$D(^AUPNVMED(^(999999911))) Q
W:$P($G(^PSRX(PSRX,2)),U,2) PSRX,!
Q
REPROC ;EP
N MSG
R "Message # to reprocess: ",MSG,!! Q:'MSG
D REP(MSG)
Q
REP(MSG) D EN^APSPPCC($NA(^XTMP("APSPPCC",MSG,"MSG")),MSG)
Q
; Fix V PROVIDER entries of 0
BADPRV ;EP
N VPRV,VIS,VMED,PSRX
F VPRV=0:0 S VPRV=$O(^AUPNVPRV("B",0,VPRV)) Q:'VPRV D
.S VIS=$P(^AUPNVPRV(VPRV,0),U,3)
.F VMED=0:0 S VMED=$O(^AUPNVMED("AD",VIS,VMED)) Q:'VMED D
..S PSRX=$O(^PSRX("APCC",VMED,0))
..Q:'PSRX
..W VMED,!
..D PROCESS^APSPPCC(PSRX)
.K DIE,DA,DR
.S DIE="^AUPNVPRV(",DA=VPRV,DR=".01///@"
.D ^DIE
Q
; Purge message logs
MSGPRG K:$$ASK^CIAU("Really purge all message logs") ^XTMP("APSPPCC")
Q
; Find all messages for a given script IEN
FNDMSG(IEN,REPROC) ;EP
N MSG,X
S IEN="|"_IEN_"^PS|",REPROC=+$G(REPROC)
F MSG=0:0 S MSG=$O(^XTMP("APSPPCC",MSG)) Q:'MSG D
.F X=0:0 S X=$O(^XTMP("APSPPCC",MSG,X)) Q:'X I ^(X)[IEN D Q
..W MSG,!
..D:REPROC REP(MSG)
Q
APSPPCCU ;IHS/CIA/DKM/PLS - Utilities for PCC Hook for Pharmacy Package ;30-Aug-2005 13:07;SM
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1003**;DEC 11, 2003
+2 ; Search for bad PSRX-->VMED link
BADP2V ;EP
+1 NEW PSRX,REF,VMED,CNT,F1
+2 WRITE "Searching for bad PSRX-->VMED links...",!!
+3 SET F1=$$ASK^CIAU("Repair bad links")
+4 IF '$LENGTH(F1)
QUIT
+5 READ "Starting PSRX: ",PSRX,!!
+6 IF PSRX[U
QUIT
+7 IF PSRX
SET PSRX=PSRX-1
+8 SET CNT=0
+9 FOR
SET PSRX=$ORDER(^PSRX(PSRX))
IF 'PSRX
QUIT
Begin DoDot:1
+10 SET VMED=$GET(^PSRX(PSRX,999999911))
SET REF=0
+11 DO BADP2VX
+12 FOR
SET REF=$ORDER(^PSRX(PSRX,1,REF))
IF 'REF
QUIT
Begin DoDot:2
+13 SET VMED=$GET(^PSRX(PSRX,1,REF,999999911))
+14 DO BADP2VX
End DoDot:2
+15 IF $X
WRITE !
End DoDot:1
+16 WRITE !!,"Bad links found: ",CNT,!!
+17 QUIT
+18 ; Check VMED
BADP2VX ;EP
+1 IF VMED
IF '$DATA(^AUPNVMED(VMED))
Begin DoDot:1
+2 WRITE $SELECT($X:",",1:PSRX_": "),REF
+3 SET CNT=CNT+1
+4 IF F1
Begin DoDot:2
+5 NEW X
+6 SET X=$$PROCESS^APSPPCC(PSRX,REF)
+7 IF X
WRITE " ",$PIECE(X,U,2),!
End DoDot:2
End DoDot:1
+8 QUIT
+9 ; Search for bad VMED-->PSRX link
BADV2P ;EP
+1 NEW VMED,CNT,F1
+2 WRITE "Searching for bad VMED-->PSRX link...",!!
+3 SET F1=$$ASK^CIAU("Remove orphaned VMED entries")
+4 IF '$LENGTH(F1)
QUIT
+5 READ "Starting VMED: ",VMED,!!
+6 IF VMED[U
QUIT
+7 IF VMED
SET VMED=VMED-1
+8 SET CNT=0
+9 FOR
SET VMED=$ORDER(^AUPNVMED(VMED))
IF 'VMED
QUIT
IF '$DATA(^PSRX("APCC",VMED))
Begin DoDot:1
+10 SET CNT=CNT+1
+11 WRITE VMED,!
+12 IF F1
Begin DoDot:2
+13 NEW DIK,DA
+14 SET DIK="^AUPNVMED("
SET DA=VMED
+15 DO ^DIK
End DoDot:2
End DoDot:1
+16 WRITE !!,"Bad links found: ",CNT,!!
+17 QUIT
+18 ; Search for scripts without VMED links
NOVMED ;EP
+1 NEW PSRX,F1
+2 WRITE "Searching for Rx's w/o PCC linkage...",!!
+3 SET F1=$$ASK^CIAU("Create entries for unlinked Rx's")
+4 IF '$LENGTH(F1)
QUIT
+5 READ "Starting PSRX: ",PSRX,!!
+6 IF PSRX[U
QUIT
+7 FOR
SET PSRX=$ORDER(^PSRX(PSRX))
IF 'PSRX
QUIT
Begin DoDot:1
+8 SET $X=1
+9 DO CHECK(PSRX)
+10 IF '$X
IF F1
Begin DoDot:2
+11 NEW X
+12 SET X=$$PROCESS^APSPPCC(PSRX)
+13 IF X
WRITE ?5,$PIECE(X,U,2),!
End DoDot:2
End DoDot:1
+14 QUIT
+15 ; Search message log for missing PCC links
MSG ;EP
+1 WRITE "Searching message log for missing PCC links...",!!
+2 NEW I1,I2,I3,Z,F1,F2
+3 SET F1=$$ASK^CIAU("Purge linked messages")
+4 SET F2=$$ASK^CIAU("Reprocess unlinked Rx's")
+5 SET I3=$ORDER(^XTMP("APSPPCC",$CHAR(1)),-1)
+6 FOR I1=0:0:I3
SET I1=$ORDER(^XTMP("APSPPCC",I1))
IF 'I1
QUIT
Begin DoDot:1
+7 WRITE *13,I1,?10
+8 FOR I2=0:0
SET I2=$ORDER(^XTMP("APSPPCC",I1,"MSG",I2))
IF 'I2
QUIT
Begin DoDot:2
+9 SET Z=^XTMP("APSPPCC",I1,"MSG",I2)
+10 IF $EXTRACT(Z,1,3)'="ORC"
QUIT
+11 SET Z=$PIECE(Z,"|",4)
+12 IF $PIECE(Z,U,2)'="PS"
QUIT
+13 SET Z=$PIECE(Z,U)
+14 IF Z=+Z
DO CHECK(Z)
+15 IF '$X
SET I2=-1
End DoDot:2
IF I2<0
QUIT
+16 IF F1
IF 'I2
KILL ^XTMP("APSPPCC",I1)
+17 IF F2
IF I2
DO REP(I1)
End DoDot:1
+18 WRITE *13,?20,!!
+19 QUIT
+20 ; Check VMED link for a script
CHECK(PSRX) ;EP
+1 NEW REF,STA
+2 SET STA=+$GET(^PSRX(PSRX,"STA"))
+3 IF STA=3!(STA=13)!(STA=16)
QUIT
+4 SET REF=$ORDER(^PSRX(PSRX,1,$CHAR(1)),-1)
+5 IF REF
Begin DoDot:1
+6 IF $GET(^PSRX(PSRX,1,REF,999999911))
IF $DATA(^AUPNVMED(^(999999911)))
QUIT
+7 IF $PIECE(^PSRX(PSRX,1,REF,0),U,18)
WRITE PSRX,":",REF,!
End DoDot:1
QUIT
+8 IF $GET(^PSRX(PSRX,999999911))
IF $DATA(^AUPNVMED(^(999999911)))
QUIT
+9 IF $PIECE($GET(^PSRX(PSRX,2)),U,2)
WRITE PSRX,!
+10 QUIT
REPROC ;EP
+1 NEW MSG
+2 READ "Message # to reprocess: ",MSG,!!
IF 'MSG
QUIT
+3 DO REP(MSG)
+4 QUIT
REP(MSG) DO EN^APSPPCC($NAME(^XTMP("APSPPCC",MSG,"MSG")),MSG)
+1 QUIT
+2 ; Fix V PROVIDER entries of 0
BADPRV ;EP
+1 NEW VPRV,VIS,VMED,PSRX
+2 FOR VPRV=0:0
SET VPRV=$ORDER(^AUPNVPRV("B",0,VPRV))
IF 'VPRV
QUIT
Begin DoDot:1
+3 SET VIS=$PIECE(^AUPNVPRV(VPRV,0),U,3)
+4 FOR VMED=0:0
SET VMED=$ORDER(^AUPNVMED("AD",VIS,VMED))
IF 'VMED
QUIT
Begin DoDot:2
+5 SET PSRX=$ORDER(^PSRX("APCC",VMED,0))
+6 IF 'PSRX
QUIT
+7 WRITE VMED,!
+8 DO PROCESS^APSPPCC(PSRX)
End DoDot:2
+9 KILL DIE,DA,DR
+10 SET DIE="^AUPNVPRV("
SET DA=VPRV
SET DR=".01///@"
+11 DO ^DIE
End DoDot:1
+12 QUIT
+13 ; Purge message logs
MSGPRG IF $$ASK^CIAU("Really purge all message logs")
KILL ^XTMP("APSPPCC")
+1 QUIT
+2 ; Find all messages for a given script IEN
FNDMSG(IEN,REPROC) ;EP
+1 NEW MSG,X
+2 SET IEN="|"_IEN_"^PS|"
SET REPROC=+$GET(REPROC)
+3 FOR MSG=0:0
SET MSG=$ORDER(^XTMP("APSPPCC",MSG))
IF 'MSG
QUIT
Begin DoDot:1
+4 FOR X=0:0
SET X=$ORDER(^XTMP("APSPPCC",MSG,X))
IF 'X
QUIT
IF ^(X)[IEN
Begin DoDot:2
+5 WRITE MSG,!
+6 IF REPROC
DO REP(MSG)
End DoDot:2
QUIT
End DoDot:1
+7 QUIT
