APSDALV ;IHS/DSD/ENM/JCM ; FIX PHARM LINKS TO VMED FILE; [ 03/13/2001 8:07 AM ]
;;V6.0;IHS PHARMACY MODIFICATIONS;**1,3**;09/03/97
;;V5.06;APSP;MAY 07, 1990
; This routine will go through the prescription file beginning
; between a site manager specified date interval. It will check
; to see the prescriptions have links to the PCC VMED file and if
; not it will create an entry. If no visit has been made for that
; date a visit with the time stamp of noon will be created, otherwise
; it will attach the V MED entry to the first visit encountered that
; day. TaskMan must be running to use this utility.
;
;------------------------------------------------------------------
START ;
D ^XBKSET
D ASK
G:'$D(ED) END
D DATE
END D EOJ
Q
;-------------------------------------------------------------------
ASK ;
S APSDALV("DUZ(0)")=DUZ(0)
S DUZ(0)="MPp"
S %DT("A")="PLEASE ENTER BEGINNING DATE: "
S %DT="AE"
D ^%DT
I Y=-1 G ASKX
S BD=Y
S %DT("A")="PLEASE ENTER ENDING DATE: "
D ^%DT
I Y=-1 G:X="" ASK G ASKX
S ED=Y
TYPE ;
S DIR(0)="9000010,.03"
S DIR("A")="TYPE OF VISIT TO CREATE"
D ^DIR
K DIR I $D(DIRUT) K DIRUT,DTOUT,DUOUT,BD,ED G ASK
S APSDALV("APCDTYPE")=Y K X,Y
CAT ;
S DIR(0)="Y"
S DIR("A")="DO YOU WANT TO CREATE HISTORICAL VISITS"
D ^DIR
K DIR I $D(DIRUT) K DIRUT,DTOUT,DUOUT,BD,ED G TYPE
I Y S APSDALV("APCDCAT")="E"
K X,Y
ASKX ;
Q
DATE ;
W !
F DATE=(BD-1):0 S DATE=$O(^PSRX("AD",DATE)) Q:(DATE>ED)!(DATE="") D RX
S DUZ(0)=APSDALV("DUZ(0)")
W !!,"All done ..."
Q
RX ;
;IRXN IS THE SUBSCRIPT PRESCRIPTION NUMBER
F IRXN=0:0 S IRXN=$O(^PSRX("AD",DATE,IRXN)) Q:IRXN="" S RFN=$O(^(IRXN,"")) D CHECK
Q
CHECK ;
Q:$P(^PSRX(IRXN,0),"^",15)=13 ;THIS RX HAS BEEN MARKED DELTED DUMBO IHS/OKCAO/POC 11/30/2000
I RFN>0,$S('$D(^PSRX(IRXN,1,RFN,999999911)):1,^(999999911)=""!(^(999999911)=" "):1,1:0) D
. S APCDALVR("APCDCAT")=$S($D(APSDALV("APCDCAT")):"E",$P(^PSRX(IRXN,0),U,3)'=1:"I",1:"A")
. S APSRX=IRXN,APSRCT=RFN
. S APCDALVR("APCDPAT")=$P(^PSRX(IRXN,0),U,2)
. S APCDALVR("APCDLOC")=DUZ(2)
. S APCDALVR("APCDTYPE")=APSDALV("APCDTYPE")
. S APC("PRV")=$P(^PSRX(IRXN,0),U,4)
. S APSPDOC1=$P($G(^VA(200,APC("PRV"),0)),U,16),APCDALVR("APCDTPRV")=$S($P($G(^AUTTSITE(1,0)),U,22):APC("PRV"),1:APSPDOC1) ;IHS/DSD/ENM 09/03/97
. S APCDALVR("APCDDATE")=$P(^PSRX(IRXN,1,RFN,0),U,1)
. D ^APSDALVR
. W "."
;
I RFN=0,$S('$D(^PSRX(IRXN,999999911)):1,^(999999911)=""!(^(999999911)=" "):1,1:0) D
. S APSRX0=^PSRX(IRXN,0)
. S APCDALVR("APCDLOC")=DUZ(2)
. S APCDALVR("APCDTYPE")=APSDALV("APCDTYPE")
. S APCDALVR("APCDPAT")=$P(APSRX0,U,2)
. S APSRX=IRXN,APCDALVR("APCDDATE")=$P(APSRX0,U,13)
. S APC("PRV")=$P(^PSRX(IRXN,0),U,4)
. S APSPDOC1=$P($G(^VA(200,APC("PRV"),0)),U,16),APCDALVR("APCDTPRV")=$S($P($G(^AUTTSITE(1,0)),U,22):APC("PRV"),1:APSPDOC1) ;IHS/DSD/ENM 09/03/97
. S APCDALVR("APCDCAT")=$S($D(APSDALV("APCDCAT")):"E",$P(APSRX0,U,3)'=1:"I",1:"A")
. D ^APSDALVN
. W "."
K RFN,APSRX,APSRCT,APSRX0,APCDALVR
Q
EOJ ;
K BD,ED,IRXN,DATE,APSDALV
Q
;NEXT PART FIXES (TRIES) TO DELETE V MED ENTRIES WITH STATUS MARKED DELETED IN THE PRESCRIPTION FILE...WHAT A MESS IHS/OKCAO/POC 11/30/2000
DEL ;
S APSDALV("DUZ(0)")=DUZ(0)
S DUZ(0)="MPp"
S %DT("A")="PLEASE ENTER BEGINNING DATE: "
S %DT="AE"
D ^%DT
I Y=-1 G ASKX
S BD=Y
S %DT("A")="PLEASE ENTER ENDING DATE: "
D ^%DT
I Y=-1 G:X="" ASK G ASKX
S ED=Y
;
;
W !
F DATE=(BD-1):0 S DATE=$O(^PSRX("AD",DATE)) Q:(DATE>ED)!(DATE="") D RXDEL
S DUZ(0)=APSDALV("DUZ(0)")
W !!,"All done ..."
Q
RXDEL ;
;IRXN IS THE SUBSCRIPT PRESCRIPTION NUMBER
F IRXN=0:0 S IRXN=$O(^PSRX("AD",DATE,IRXN)) Q:IRXN="" S RFN=$O(^(IRXN,"")) D CHECKDEL
Q
CHECKDEL ;
;I RFN>0,$S('$D(^PSRX(IRXN,1,RFN,999999911)):1,^(999999911)=""!(^(999999911)=" "):1,1:0) D
I RFN>0 Q ;SHOULDN'T BE A PROBLEM WITH REFILLS
;
I RFN=0 D
.Q:$P(^PSRX(IRXN,0),"^",15)'=13 ;STOP IF THIS IS NOT MARKED DELETED
.S APSRX=IRXN
.S APSRM=+$G(^PSRX(IRXN,999999911))
.Q:'APSRM ;GOT NOTHING TO TRY TO DELETE IN VMED
.S ^AZOPAT("DEL",IRXN,APSRM)="" ;THIS IS DA OF RX, DA OF V MED FILE
.S DIE="^PSRX(",DR="9999999.11///@",DA=IRXN D ^DIE
.D ^APSPCCD
.W "."
K RFN,APSRX,APSRCT,APSRX0,APCDALVR
Q
EOJD ;
APSDALV ;IHS/DSD/ENM/JCM ; FIX PHARM LINKS TO VMED FILE; [ 03/13/2001 8:07 AM ]
+1 ;;V6.0;IHS PHARMACY MODIFICATIONS;**1,3**;09/03/97
+2 ;;V5.06;APSP;MAY 07, 1990
+3 ; This routine will go through the prescription file beginning
+4 ; between a site manager specified date interval. It will check
+5 ; to see the prescriptions have links to the PCC VMED file and if
+6 ; not it will create an entry. If no visit has been made for that
+7 ; date a visit with the time stamp of noon will be created, otherwise
+8 ; it will attach the V MED entry to the first visit encountered that
+9 ; day. TaskMan must be running to use this utility.
+10 ;
+11 ;------------------------------------------------------------------
START ;
+1 DO ^XBKSET
+2 DO ASK
+3 IF '$DATA(ED)
GOTO END
+4 DO DATE
END DO EOJ
+1 QUIT
+2 ;-------------------------------------------------------------------
ASK ;
+1 SET APSDALV("DUZ(0)")=DUZ(0)
+2 SET DUZ(0)="MPp"
+3 SET %DT("A")="PLEASE ENTER BEGINNING DATE: "
+4 SET %DT="AE"
+5 DO ^%DT
+6 IF Y=-1
GOTO ASKX
+7 SET BD=Y
+8 SET %DT("A")="PLEASE ENTER ENDING DATE: "
+9 DO ^%DT
+10 IF Y=-1
IF X=""
GOTO ASK
GOTO ASKX
+11 SET ED=Y
TYPE ;
+1 SET DIR(0)="9000010,.03"
+2 SET DIR("A")="TYPE OF VISIT TO CREATE"
+3 DO ^DIR
+4 KILL DIR
IF $DATA(DIRUT)
KILL DIRUT,DTOUT,DUOUT,BD,ED
GOTO ASK
+5 SET APSDALV("APCDTYPE")=Y
KILL X,Y
CAT ;
+1 SET DIR(0)="Y"
+2 SET DIR("A")="DO YOU WANT TO CREATE HISTORICAL VISITS"
+3 DO ^DIR
+4 KILL DIR
IF $DATA(DIRUT)
KILL DIRUT,DTOUT,DUOUT,BD,ED
GOTO TYPE
+5 IF Y
SET APSDALV("APCDCAT")="E"
+6 KILL X,Y
ASKX ;
+1 QUIT
DATE ;
+1 WRITE !
+2 FOR DATE=(BD-1):0
SET DATE=$ORDER(^PSRX("AD",DATE))
IF (DATE>ED)!(DATE="")
QUIT
DO RX
+3 SET DUZ(0)=APSDALV("DUZ(0)")
+4 WRITE !!,"All done ..."
+5 QUIT
RX ;
+1 ;IRXN IS THE SUBSCRIPT PRESCRIPTION NUMBER
+2 FOR IRXN=0:0
SET IRXN=$ORDER(^PSRX("AD",DATE,IRXN))
IF IRXN=""
QUIT
SET RFN=$ORDER(^(IRXN,""))
DO CHECK
+3 QUIT
CHECK ;
+1 ;THIS RX HAS BEEN MARKED DELTED DUMBO IHS/OKCAO/POC 11/30/2000
IF $PIECE(^PSRX(IRXN,0),"^",15)=13
QUIT
+2 IF RFN>0
IF $SELECT('$DATA(^PSRX(IRXN,1,RFN,999999911)):1,^(999999911)=""!(^(999999911)=" "):1,1:0)
Begin DoDot:1
+3 SET APCDALVR("APCDCAT")=$SELECT($DATA(APSDALV("APCDCAT")):"E",$PIECE(^PSRX(IRXN,0),U,3)'=1:"I",1:"A")
+4 SET APSRX=IRXN
SET APSRCT=RFN
+5 SET APCDALVR("APCDPAT")=$PIECE(^PSRX(IRXN,0),U,2)
+6 SET APCDALVR("APCDLOC")=DUZ(2)
+7 SET APCDALVR("APCDTYPE")=APSDALV("APCDTYPE")
+8 SET APC("PRV")=$PIECE(^PSRX(IRXN,0),U,4)
+9 ;IHS/DSD/ENM 09/03/97
SET APSPDOC1=$PIECE($GET(^VA(200,APC("PRV"),0)),U,16)
SET APCDALVR("APCDTPRV")=$SELECT($PIECE($GET(^AUTTSITE(1,0)),U,22):APC("PRV"),1:APSPDOC1)
+10 SET APCDALVR("APCDDATE")=$PIECE(^PSRX(IRXN,1,RFN,0),U,1)
+11 DO ^APSDALVR
+12 WRITE "."
End DoDot:1
+13 ;
+14 IF RFN=0
IF $SELECT('$DATA(^PSRX(IRXN,999999911)):1,^(999999911)=""!(^(999999911)=" "):1,1:0)
Begin DoDot:1
+15 SET APSRX0=^PSRX(IRXN,0)
+16 SET APCDALVR("APCDLOC")=DUZ(2)
+17 SET APCDALVR("APCDTYPE")=APSDALV("APCDTYPE")
+18 SET APCDALVR("APCDPAT")=$PIECE(APSRX0,U,2)
+19 SET APSRX=IRXN
SET APCDALVR("APCDDATE")=$PIECE(APSRX0,U,13)
+20 SET APC("PRV")=$PIECE(^PSRX(IRXN,0),U,4)
+21 ;IHS/DSD/ENM 09/03/97
SET APSPDOC1=$PIECE($GET(^VA(200,APC("PRV"),0)),U,16)
SET APCDALVR("APCDTPRV")=$SELECT($PIECE($GET(^AUTTSITE(1,0)),U,22):APC("PRV"),1:APSPDOC1)
+22 SET APCDALVR("APCDCAT")=$SELECT($DATA(APSDALV("APCDCAT")):"E",$PIECE(APSRX0,U,3)'=1:"I",1:"A")
+23 DO ^APSDALVN
+24 WRITE "."
End DoDot:1
+25 KILL RFN,APSRX,APSRCT,APSRX0,APCDALVR
+26 QUIT
EOJ ;
+1 KILL BD,ED,IRXN,DATE,APSDALV
+2 QUIT
+3 ;NEXT PART FIXES (TRIES) TO DELETE V MED ENTRIES WITH STATUS MARKED DELETED IN THE PRESCRIPTION FILE...WHAT A MESS IHS/OKCAO/POC 11/30/2000
DEL ;
+1 SET APSDALV("DUZ(0)")=DUZ(0)
+2 SET DUZ(0)="MPp"
+3 SET %DT("A")="PLEASE ENTER BEGINNING DATE: "
+4 SET %DT="AE"
+5 DO ^%DT
+6 IF Y=-1
GOTO ASKX
+7 SET BD=Y
+8 SET %DT("A")="PLEASE ENTER ENDING DATE: "
+9 DO ^%DT
+10 IF Y=-1
IF X=""
GOTO ASK
GOTO ASKX
+11 SET ED=Y
+12 ;
+13 ;
+14 WRITE !
+15 FOR DATE=(BD-1):0
SET DATE=$ORDER(^PSRX("AD",DATE))
IF (DATE>ED)!(DATE="")
QUIT
DO RXDEL
+16 SET DUZ(0)=APSDALV("DUZ(0)")
+17 WRITE !!,"All done ..."
+18 QUIT
RXDEL ;
+1 ;IRXN IS THE SUBSCRIPT PRESCRIPTION NUMBER
+2 FOR IRXN=0:0
SET IRXN=$ORDER(^PSRX("AD",DATE,IRXN))
IF IRXN=""
QUIT
SET RFN=$ORDER(^(IRXN,""))
DO CHECKDEL
+3 QUIT
CHECKDEL ;
+1 ;I RFN>0,$S('$D(^PSRX(IRXN,1,RFN,999999911)):1,^(999999911)=""!(^(999999911)=" "):1,1:0) D
+2 ;SHOULDN'T BE A PROBLEM WITH REFILLS
IF RFN>0
QUIT
+3 ;
+4 IF RFN=0
Begin DoDot:1
+5 ;STOP IF THIS IS NOT MARKED DELETED
IF $PIECE(^PSRX(IRXN,0),"^",15)'=13
QUIT
+6 SET APSRX=IRXN
+7 SET APSRM=+$GET(^PSRX(IRXN,999999911))
+8 ;GOT NOTHING TO TRY TO DELETE IN VMED
IF 'APSRM
QUIT
+9 ;THIS IS DA OF RX, DA OF V MED FILE
SET ^AZOPAT("DEL",IRXN,APSRM)=""
+10 SET DIE="^PSRX("
SET DR="9999999.11///@"
SET DA=IRXN
DO ^DIE
+11 DO ^APSPCCD
+12 WRITE "."
End DoDot:1
+13 KILL RFN,APSRX,APSRCT,APSRX0,APCDALVR
+14 QUIT
EOJD ;
