PSARDCBL ;BIRM/MHA - Return Drug Batch Work List - ListMan ;07/01/08
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**69,72**;10/24/97;Build 2
;
ST ; Entry point
I '$$CHKEY^PSARDCUT() Q ;security key check
N PSAPHLOC,PSADTRNG,PSABASTS
;
; - Pharmacy location selection
S PSAPHLOC=$$PHLOC^PSARDCUT() I 'PSAPHLOC Q
;
; - Date range selection
S PSADTRNG=""
;
; - Return drug credit status selection
S PSABASTS="AP,PU"
D EN(PSAPHLOC,PSADTRNG,PSABASTS)
Q
EN(PSAPHLOC,PSADT,PSASTA) ;- ListManager entry point
N PSALOC S PSALOC=+PSAPHLOC
N LASTLINE
LST ; - ListManager entry point
D EN^VALM("PSA RETURN DRUG BATCH LIST")
D FULL^VALM1
G EXIT
;
HDR ; - Header
N LINE1,LINE2,LINE3,LINE4
S LINE1="Pharmacy Location: "_$P(PSAPHLOC,"^",2)
S LINE2="Date Range : "_$S(+PSADT:$$FMTE^XLFDT(+PSADT,"2Z"),1:"ALL")_$S(+$P(PSADT,"^",2):" THRU "_$$FMTE^XLFDT(+$P(PSADT,"^",2),"2Z"),1:"")
K VALMHDR
S VALMHDR(1)=LINE1,VALMHDR(2)=LINE2
N HDR
S HDR=" DATE DATE DATE TOTAL # OF"
S $E(HDR,81)="" D INSTR^VALM1(IORVON_HDR_IOINORM,1,4)
S HDR=" # BATCH # CREATED PICKED UP COMPLETED CREDIT RETURN CONTRACTOR ITEMS"
S $E(HDR,81)="" D INSTR^VALM1(IORVON_HDR_IOINORM,1,5)
Q
;
INIT ; - Populates the Body section for ListMan
K ^TMP("PSARDCBL",$J),^TMP("PSATMP",$J)
S VALMCNT=0
D SORT,SETLINE
S VALMSG="Select the entry # to view or ?? for more actions"
Q
;
SORT ; - Sort according to the status to be displayed in ListMan
N BAT,STA,SEQ,ARR,SDT,EDT,FDT
S SDT=$P(PSADT,"^"),SDT=$S(+SDT>0:SDT,1:0)
S EDT=$P(PSADT,"^",2),EDT=$S(+EDT>0:EDT_".9",1:9999999)
F I=1:1:$L(PSASTA,",") S ARR($P(PSASTA,",",I))=""
S (BAT,SEQ)=0
F S BAT=$O(^PSD(58.35,PSALOC,"BAT",BAT)) Q:'BAT D
. S STA=$$GET1^DIQ(58.351,BAT_","_PSALOC,1,"I") I STA="" Q
. I '$D(ARR("ALL")),'$D(ARR(STA)) Q
. S FDT=$$GET1^DIQ(58.351,BAT_","_PSALOC,3,"I")
. I (SDT>FDT)!(FDT>EDT) Q
. S ^TMP("PSATMP",$J,STA,BAT)=""
Q
;
SETLINE ; - Sets the line to be displayed in ListMan
; - Resetting list to NORMAL video attributes
F I=1:1:$G(LASTLINE) D RESTORE^VALM10(I)
;
N BAT,REC,STA,SEQ,FLDS,BATN,DTCR,DTPU,DTCP,TOTC,CMFR,NIT,LN,DSTA,CNT,GRPLN
S (BAT,SEQ,CNT,PSACNT)=0,STA=""
F S STA=$O(^TMP("PSATMP",$J,STA)) Q:STA="" D
.S LN="",DSTA=$$EXTERNAL^DILFD(58.351,1,,STA),$E(LN,(41-($L(DSTA)\2)))=DSTA
.S SEQ=SEQ+1,VALMCNT=VALMCNT+1,^TMP("PSARDCBL",$J,SEQ,0)=LN,GRPLN(SEQ)=DSTA
.F S BAT=$O(^TMP("PSATMP",$J,STA,BAT)) Q:'BAT D
. .D GETS^DIQ(58.351,BAT_","_PSALOC_",","*","IE","FLDS")
. .K REC M REC=FLDS(58.351,BAT_","_PSALOC_",") K FLDS Q:'REC(.01,"E")
. .S SEQ=SEQ+1,CNT=CNT+1,BATN=REC(.01,"E"),DTCR=$$FMTE^XLFDT($E(REC(3,"I"),1,7),"2Z"),DTPU=$$FMTE^XLFDT($E(REC(2,"I"),1,7),"2Z")
. .S DTCP=$$FMTE^XLFDT($E(REC(9,"I"),1,7),"2Z")
. .S CMFR=$E(REC(4,"E"),1,20)
. .S TOTC=$J($P($$TOTCRE^PSARDCUT(PSALOC,BAT),"^",2),0,2)
. .S (LN,NIT)=0 D NIT
. .;Display Line
. .S LN="",LN=$J(CNT,3),$E(LN,5)=BATN,$E(LN,15)=DTCR,$E(LN,25)=DTPU,$E(LN,35)=DTCP,$E(LN,45)=$J(TOTC,10),$E(LN,57)=CMFR,$E(LN,78)=$J(NIT,3)
. .S ^TMP("PSARDCBL",$J,SEQ,0)=LN,VALMCNT=VALMCNT+1
. .S ^TMP("PSARDCBL",$J,CNT,"BAT")=BAT
;
S PSACNT=CNT
; - Saving NORMAL video attributes to be reset later
I SEQ>$G(LASTLINE) D
. F I=($G(LASTLINE)+1):1:SEQ D SAVE^VALM10(I)
. S LASTLINE=SEQ
;
I '$D(^TMP("PSARDCBL",$J)) D
. S ^TMP("PSARDCBL",$J,7,0)=" No batches to display"
. S VALMCNT=0
D RV
Q
;
; - Highlighting the group lines (order type and status)
RV ;
S LN=0 F S LN=$O(GRPLN(LN)) Q:'LN D
. S DSTA=GRPLN(LN),CNT=41-($L(DSTA)\2)
. D CNTRL^VALM10(LN,1,CNT-1,IOUON_IOINHI,IOINORM)
. D CNTRL^VALM10(LN,CNT,$L(DSTA),IORVON_IOINHI,IORVOFF_IOINORM)
. D CNTRL^VALM10(LN,CNT+$L(DSTA),81-CNT-$L(DSTA),IOUON_IOINHI,IOINORM)
Q
NIT ;
F S LN=$O(^PSD(58.35,PSALOC,"BAT",BAT,"ITM",LN)) Q:'LN I $D(^(LN,0)) S NIT=NIT+1
Q
;
ADD ; - Add New Batch
I '$D(^PSD(58.35,PSALOC)) D
. N DIC,DA,X,DINUM
. S DIC="^PSD(58.35,",(DINUM,X)=PSALOC,DIC(0)=""
. K DD,DO D FILE^DICN D:Y<1 K DD,DO
. . S $P(^PSD(58.35,PSALOC,0),"^")=PSALOC K DIK S DA=PSALOC,DIK="^PSD(58.35,",DIK(1)=.01 D EN^DIK K DIK
N PSABAT,I,J,CMF,PSALK S (PSALK,PSABAT)=$E(DT,4,5)_$E(DT,2,3)
L +^PSD(58.35,PSALOC,PSALK):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W $C(7),!!,"**** The File is Being Edited by Another User - Try Later ****",! H 3 G ADDQ
S J=$O(^PSD(58.35,PSALOC,"BAT","B",PSABAT_"-999"),-1)
S J=$S(PSABAT=$E(J,1,4):$P(J,"-",2),1:0)
S PSABAT=PSABAT_"-"_$E(1000+(J+1),2,4)
D FULL^VALM1 W !!," New Batch #: "_PSABAT
K DIC,Y,X
S DIC="^PSD(58.36,",DIC(0)="QEAM",DIC("A")=" RETURN CONTRACTOR: "
S DIC("S")="I $S($P($G(^(0)),""^"",2):$P($G(^(0)),""^"",2)>DT,1:1)"
S DIC("B")=$P($$DEFCTMF^PSARDCUT(),"^",2) K:DIC("B")="" DIC("B")
D ^DIC I X=""!$D(DTOUT)!$D(DUOUT) K DTOUT,DUOUT D G ADDQ
. W !!,"Batch not created - contracter/mfr not entered!",! N DIR S DIR(0)="E" D ^DIR
S CMF=+Y
W ! K DIR,X,Y S DIR(0)="Y",DIR("B")="NO",DIR("A")="Save Batch" D ^DIR K DIR G:Y<1 ADDQ
D NOW^%DTC
N DIC,DR,DA,X,DINUM,DLAYGO,DD,DO
S DIC="^PSD(58.35,"_PSALOC_",""BAT"",",X=PSABAT,DIC(0)=""
S DA(1)=PSALOC,DIC("DR")="1////"_"AP"_";3////"_%_";4////"_CMF
K DD,DO,% D FILE^DICN K DD,DO L -^PSD(58.35,PSALOC,PSALK)
;
D ;
. N XQORM
. D EN^PSARDCBA(PSALOC,+Y)
;
ADDQ L -^PSD(58.35,PSALOC,PSALK) D INIT S VALMBCK="R"
Q
;
CMF ; - Add/Edit Contractor
L +^PSD(58.36):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W $C(7),!!,"**** The File is Being Edited by Another User - Try Later ****",! H 3 G CMFQ
D FULL^VALM1 W !
N FQ F FQ=0:0 K DIC S DIC="^PSD(58.36,",DIC(0)="AEQLS",DLAYGO=58.36 D ^DIC K DIC Q:Y'>0 D
. S DR=".01//^S X=$G(DIC_+Y_"",0"";1//",DIE="^PSD(58.36,",DA=+Y D ^DIE K DA,DIE,DR W !
L -^PSD(58.36)
CMFQ D INIT S VALMBCK="R"
Q
;
SEL ; - Select Item action
I VALMCNT=0 S VALMSG="There are no batches to select!",VALMBCK="R" W $C(7) Q
N PSASEL,BAT
S PSASEL=+$P($P($G(Y(1)),"^",4),"=",2)
I $G(PSASEL),'$D(^TMP("PSARDCBL",$J,PSASEL,"BAT")) D Q
. S VALMSG="Invalid selection!",VALMBCK="R" W $C(7)
I '$G(^TMP("PSARDCBL",$J,PSASEL,"BAT")) D I 'PSASEL S VALMBCK="R" Q
. N DIR,Y,X,DIRUT,DIROUT
. D FULL^VALM1 S DIR(0)="N^1:"_PSACNT,DIR("A")="SELECT RETURN BATCH"
.
. W ! D ^DIR I $D(DIRUT)!$D(DIROUT)!(Y'>0) S VALMBCK="R" Q
. S PSASEL=+Y
;
S BAT=$G(^TMP("PSARDCBL",$J,PSASEL,"BAT"))
D ;
. N XQORM
. D EN^PSARDCBA(PSALOC,BAT),INIT
;
S VALMBCK="R"
Q
;
CBAT ; Complete Batch
I '$$CHKEY^PSARDCUT() Q ;security key check
N PSAPHLOC,PSADTRNG,PSABASTS
;
; - Pharmacy location selection
S PSAPHLOC=$$PHLOC^PSARDCUT() I 'PSAPHLOC Q
;
; - Date range selection
W ! S PSADTRNG=$$DTRNG^PSARDCUT("T-90","T") I PSADTRNG="^" Q
;
; - Return drug credit status selection
W ! S PSABASTS=$$STASEL^PSARDCUT() I PSABASTS="" Q
;
; - Call ListMan driver for Batch List Processing
D EN(PSAPHLOC,PSADTRNG,PSABASTS)
Q
;
EXIT ;
K ^TMP("PSARDCBL",$J),^TMP("PSATMP",$J),PSACNT
Q
;
HELP Q
;
DELCMF(DA) ; check if cmf has entries tied to it
I $G(DA)="" Q 1
N PSADEL,I,J
S (PSADEL,I)=0
F S I=$O(^PSD(58.35,I)) Q:'I S J=0 F S J=$O(^PSD(58.35,I,"BAT",J)) Q:'J I $P($G(^PSD(58.35,I,"BAT",J,0)),"^",5)=+DA S PSADEL=1
Q PSADEL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSARDCBL 7380 printed Sep 23, 2025@19:26:25 Page 2
PSARDCBL ;BIRM/MHA - Return Drug Batch Work List - ListMan ;07/01/08
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**69,72**;10/24/97;Build 2
+2 ;
ST ; Entry point
+1 ;security key check
IF '$$CHKEY^PSARDCUT()
QUIT
+2 NEW PSAPHLOC,PSADTRNG,PSABASTS
+3 ;
+4 ; - Pharmacy location selection
+5 SET PSAPHLOC=$$PHLOC^PSARDCUT()
IF 'PSAPHLOC
QUIT
+6 ;
+7 ; - Date range selection
+8 SET PSADTRNG=""
+9 ;
+10 ; - Return drug credit status selection
+11 SET PSABASTS="AP,PU"
+12 DO EN(PSAPHLOC,PSADTRNG,PSABASTS)
+13 QUIT
EN(PSAPHLOC,PSADT,PSASTA) ;- ListManager entry point
+1 NEW PSALOC
SET PSALOC=+PSAPHLOC
+2 NEW LASTLINE
LST ; - ListManager entry point
+1 DO EN^VALM("PSA RETURN DRUG BATCH LIST")
+2 DO FULL^VALM1
+3 GOTO EXIT
+4 ;
HDR ; - Header
+1 NEW LINE1,LINE2,LINE3,LINE4
+2 SET LINE1="Pharmacy Location: "_$PIECE(PSAPHLOC,"^",2)
+3 SET LINE2="Date Range : "_$SELECT(+PSADT:$$FMTE^XLFDT(+PSADT,"2Z"),1:"ALL")_$SELECT(+$PIECE(PSADT,"^",2):" THRU "_$$FMTE^XLFDT(+$PIECE(PSADT,"^",2),"2Z"),1:"")
+4 KILL VALMHDR
+5 SET VALMHDR(1)=LINE1
SET VALMHDR(2)=LINE2
+6 NEW HDR
+7 SET HDR=" DATE DATE DATE TOTAL # OF"
+8 SET $EXTRACT(HDR,81)=""
DO INSTR^VALM1(IORVON_HDR_IOINORM,1,4)
+9 SET HDR=" # BATCH # CREATED PICKED UP COMPLETED CREDIT RETURN CONTRACTOR ITEMS"
+10 SET $EXTRACT(HDR,81)=""
DO INSTR^VALM1(IORVON_HDR_IOINORM,1,5)
+11 QUIT
+12 ;
INIT ; - Populates the Body section for ListMan
+1 KILL ^TMP("PSARDCBL",$JOB),^TMP("PSATMP",$JOB)
+2 SET VALMCNT=0
+3 DO SORT
DO SETLINE
+4 SET VALMSG="Select the entry # to view or ?? for more actions"
+5 QUIT
+6 ;
SORT ; - Sort according to the status to be displayed in ListMan
+1 NEW BAT,STA,SEQ,ARR,SDT,EDT,FDT
+2 SET SDT=$PIECE(PSADT,"^")
SET SDT=$SELECT(+SDT>0:SDT,1:0)
+3 SET EDT=$PIECE(PSADT,"^",2)
SET EDT=$SELECT(+EDT>0:EDT_".9",1:9999999)
+4 FOR I=1:1:$LENGTH(PSASTA,",")
SET ARR($PIECE(PSASTA,",",I))=""
+5 SET (BAT,SEQ)=0
+6 FOR
SET BAT=$ORDER(^PSD(58.35,PSALOC,"BAT",BAT))
if 'BAT
QUIT
Begin DoDot:1
+7 SET STA=$$GET1^DIQ(58.351,BAT_","_PSALOC,1,"I")
IF STA=""
QUIT
+8 IF '$DATA(ARR("ALL"))
IF '$DATA(ARR(STA))
QUIT
+9 SET FDT=$$GET1^DIQ(58.351,BAT_","_PSALOC,3,"I")
+10 IF (SDT>FDT)!(FDT>EDT)
QUIT
+11 SET ^TMP("PSATMP",$JOB,STA,BAT)=""
End DoDot:1
+12 QUIT
+13 ;
SETLINE ; - Sets the line to be displayed in ListMan
+1 ; - Resetting list to NORMAL video attributes
+2 FOR I=1:1:$GET(LASTLINE)
DO RESTORE^VALM10(I)
+3 ;
+4 NEW BAT,REC,STA,SEQ,FLDS,BATN,DTCR,DTPU,DTCP,TOTC,CMFR,NIT,LN,DSTA,CNT,GRPLN
+5 SET (BAT,SEQ,CNT,PSACNT)=0
SET STA=""
+6 FOR
SET STA=$ORDER(^TMP("PSATMP",$JOB,STA))
if STA=""
QUIT
Begin DoDot:1
+7 SET LN=""
SET DSTA=$$EXTERNAL^DILFD(58.351,1,,STA)
SET $EXTRACT(LN,(41-($LENGTH(DSTA)\2)))=DSTA
+8 SET SEQ=SEQ+1
SET VALMCNT=VALMCNT+1
SET ^TMP("PSARDCBL",$JOB,SEQ,0)=LN
SET GRPLN(SEQ)=DSTA
+9 FOR
SET BAT=$ORDER(^TMP("PSATMP",$JOB,STA,BAT))
if 'BAT
QUIT
Begin DoDot:2
+10 DO GETS^DIQ(58.351,BAT_","_PSALOC_",","*","IE","FLDS")
+11 KILL REC
MERGE REC=FLDS(58.351,BAT_","_PSALOC_",")
KILL FLDS
if 'REC(.01,"E")
QUIT
+12 SET SEQ=SEQ+1
SET CNT=CNT+1
SET BATN=REC(.01,"E")
SET DTCR=$$FMTE^XLFDT($EXTRACT(REC(3,"I"),1,7),"2Z")
SET DTPU=$$FMTE^XLFDT($EXTRACT(REC(2,"I"),1,7),"2Z")
+13 SET DTCP=$$FMTE^XLFDT($EXTRACT(REC(9,"I"),1,7),"2Z")
+14 SET CMFR=$EXTRACT(REC(4,"E"),1,20)
+15 SET TOTC=$JUSTIFY($PIECE($$TOTCRE^PSARDCUT(PSALOC,BAT),"^",2),0,2)
+16 SET (LN,NIT)=0
DO NIT
+17 ;Display Line
+18 SET LN=""
SET LN=$JUSTIFY(CNT,3)
SET $EXTRACT(LN,5)=BATN
SET $EXTRACT(LN,15)=DTCR
SET $EXTRACT(LN,25)=DTPU
SET $EXTRACT(LN,35)=DTCP
SET $EXTRACT(LN,45)=$JUSTIFY(TOTC,10)
SET $EXTRACT(LN,57)=CMFR
SET $EXTRACT(LN,78)=$JUSTIFY(NIT,3)
+19 SET ^TMP("PSARDCBL",$JOB,SEQ,0)=LN
SET VALMCNT=VALMCNT+1
+20 SET ^TMP("PSARDCBL",$JOB,CNT,"BAT")=BAT
End DoDot:2
End DoDot:1
+21 ;
+22 SET PSACNT=CNT
+23 ; - Saving NORMAL video attributes to be reset later
+24 IF SEQ>$GET(LASTLINE)
Begin DoDot:1
+25 FOR I=($GET(LASTLINE)+1):1:SEQ
DO SAVE^VALM10(I)
+26 SET LASTLINE=SEQ
End DoDot:1
+27 ;
+28 IF '$DATA(^TMP("PSARDCBL",$JOB))
Begin DoDot:1
+29 SET ^TMP("PSARDCBL",$JOB,7,0)=" No batches to display"
+30 SET VALMCNT=0
End DoDot:1
+31 DO RV
+32 QUIT
+33 ;
+34 ; - Highlighting the group lines (order type and status)
RV ;
+1 SET LN=0
FOR
SET LN=$ORDER(GRPLN(LN))
if 'LN
QUIT
Begin DoDot:1
+2 SET DSTA=GRPLN(LN)
SET CNT=41-($LENGTH(DSTA)\2)
+3 DO CNTRL^VALM10(LN,1,CNT-1,IOUON_IOINHI,IOINORM)
+4 DO CNTRL^VALM10(LN,CNT,$LENGTH(DSTA),IORVON_IOINHI,IORVOFF_IOINORM)
+5 DO CNTRL^VALM10(LN,CNT+$LENGTH(DSTA),81-CNT-$LENGTH(DSTA),IOUON_IOINHI,IOINORM)
End DoDot:1
+6 QUIT
NIT ;
+1 FOR
SET LN=$ORDER(^PSD(58.35,PSALOC,"BAT",BAT,"ITM",LN))
if 'LN
QUIT
IF $DATA(^(LN,0))
SET NIT=NIT+1
+2 QUIT
+3 ;
ADD ; - Add New Batch
+1 IF '$DATA(^PSD(58.35,PSALOC))
Begin DoDot:1
+2 NEW DIC,DA,X,DINUM
+3 SET DIC="^PSD(58.35,"
SET (DINUM,X)=PSALOC
SET DIC(0)=""
+4 KILL DD,DO
DO FILE^DICN
if Y<1
Begin DoDot:2
+5 SET $PIECE(^PSD(58.35,PSALOC,0),"^")=PSALOC
KILL DIK
SET DA=PSALOC
SET DIK="^PSD(58.35,"
SET DIK(1)=.01
DO EN^DIK
KILL DIK
End DoDot:2
KILL DD,DO
End DoDot:1
+6 NEW PSABAT,I,J,CMF,PSALK
SET (PSALK,PSABAT)=$EXTRACT(DT,4,5)_$EXTRACT(DT,2,3)
+7 LOCK +^PSD(58.35,PSALOC,PSALK):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
IF '$TEST
WRITE $CHAR(7),!!,"**** The File is Being Edited by Another User - Try Later ****",!
HANG 3
GOTO ADDQ
+8 SET J=$ORDER(^PSD(58.35,PSALOC,"BAT","B",PSABAT_"-999"),-1)
+9 SET J=$SELECT(PSABAT=$EXTRACT(J,1,4):$PIECE(J,"-",2),1:0)
+10 SET PSABAT=PSABAT_"-"_$EXTRACT(1000+(J+1),2,4)
+11 DO FULL^VALM1
WRITE !!," New Batch #: "_PSABAT
+12 KILL DIC,Y,X
+13 SET DIC="^PSD(58.36,"
SET DIC(0)="QEAM"
SET DIC("A")=" RETURN CONTRACTOR: "
+14 SET DIC("S")="I $S($P($G(^(0)),""^"",2):$P($G(^(0)),""^"",2)>DT,1:1)"
+15 SET DIC("B")=$PIECE($$DEFCTMF^PSARDCUT(),"^",2)
if DIC("B")=""
KILL DIC("B")
+16 DO ^DIC
IF X=""!$DATA(DTOUT)!$DATA(DUOUT)
KILL DTOUT,DUOUT
Begin DoDot:1
+17 WRITE !!,"Batch not created - contracter/mfr not entered!",!
NEW DIR
SET DIR(0)="E"
DO ^DIR
End DoDot:1
GOTO ADDQ
+18 SET CMF=+Y
+19 WRITE !
KILL DIR,X,Y
SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Save Batch"
DO ^DIR
KILL DIR
if Y<1
GOTO ADDQ
+20 DO NOW^%DTC
+21 NEW DIC,DR,DA,X,DINUM,DLAYGO,DD,DO
+22 SET DIC="^PSD(58.35,"_PSALOC_",""BAT"","
SET X=PSABAT
SET DIC(0)=""
+23 SET DA(1)=PSALOC
SET DIC("DR")="1////"_"AP"_";3////"_%_";4////"_CMF
+24 KILL DD,DO,%
DO FILE^DICN
KILL DD,DO
LOCK -^PSD(58.35,PSALOC,PSALK)
+25 ;
+26 ;
Begin DoDot:1
+27 NEW XQORM
+28 DO EN^PSARDCBA(PSALOC,+Y)
End DoDot:1
+29 ;
ADDQ LOCK -^PSD(58.35,PSALOC,PSALK)
DO INIT
SET VALMBCK="R"
+1 QUIT
+2 ;
CMF ; - Add/Edit Contractor
+1 LOCK +^PSD(58.36):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
IF '$TEST
WRITE $CHAR(7),!!,"**** The File is Being Edited by Another User - Try Later ****",!
HANG 3
GOTO CMFQ
+2 DO FULL^VALM1
WRITE !
+3 NEW FQ
FOR FQ=0:0
KILL DIC
SET DIC="^PSD(58.36,"
SET DIC(0)="AEQLS"
SET DLAYGO=58.36
DO ^DIC
KILL DIC
if Y'>0
QUIT
Begin DoDot:1
+4 SET DR=".01//^S X=$G(DIC_+Y_"",0"";1//"
SET DIE="^PSD(58.36,"
SET DA=+Y
DO ^DIE
KILL DA,DIE,DR
WRITE !
End DoDot:1
+5 LOCK -^PSD(58.36)
CMFQ DO INIT
SET VALMBCK="R"
+1 QUIT
+2 ;
SEL ; - Select Item action
+1 IF VALMCNT=0
SET VALMSG="There are no batches to select!"
SET VALMBCK="R"
WRITE $CHAR(7)
QUIT
+2 NEW PSASEL,BAT
+3 SET PSASEL=+$PIECE($PIECE($GET(Y(1)),"^",4),"=",2)
+4 IF $GET(PSASEL)
IF '$DATA(^TMP("PSARDCBL",$JOB,PSASEL,"BAT"))
Begin DoDot:1
+5 SET VALMSG="Invalid selection!"
SET VALMBCK="R"
WRITE $CHAR(7)
End DoDot:1
QUIT
+6 IF '$GET(^TMP("PSARDCBL",$JOB,PSASEL,"BAT"))
Begin DoDot:1
+7 NEW DIR,Y,X,DIRUT,DIROUT
+8 DO FULL^VALM1
SET DIR(0)="N^1:"_PSACNT
SET DIR("A")="SELECT RETURN BATCH"
+9 +10 WRITE !
DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)!(Y'>0)
SET VALMBCK="R"
QUIT
+11 SET PSASEL=+Y
End DoDot:1
IF 'PSASEL
SET VALMBCK="R"
QUIT
+12 ;
+13 SET BAT=$GET(^TMP("PSARDCBL",$JOB,PSASEL,"BAT"))
+14 ;
Begin DoDot:1
+15 NEW XQORM
+16 DO EN^PSARDCBA(PSALOC,BAT)
DO INIT
End DoDot:1
+17 ;
+18 SET VALMBCK="R"
+19 QUIT
+20 ;
CBAT ; Complete Batch
+1 ;security key check
IF '$$CHKEY^PSARDCUT()
QUIT
+2 NEW PSAPHLOC,PSADTRNG,PSABASTS
+3 ;
+4 ; - Pharmacy location selection
+5 SET PSAPHLOC=$$PHLOC^PSARDCUT()
IF 'PSAPHLOC
QUIT
+6 ;
+7 ; - Date range selection
+8 WRITE !
SET PSADTRNG=$$DTRNG^PSARDCUT("T-90","T")
IF PSADTRNG="^"
QUIT
+9 ;
+10 ; - Return drug credit status selection
+11 WRITE !
SET PSABASTS=$$STASEL^PSARDCUT()
IF PSABASTS=""
QUIT
+12 ;
+13 ; - Call ListMan driver for Batch List Processing
+14 DO EN(PSAPHLOC,PSADTRNG,PSABASTS)
+15 QUIT
+16 ;
EXIT ;
+1 KILL ^TMP("PSARDCBL",$JOB),^TMP("PSATMP",$JOB),PSACNT
+2 QUIT
+3 ;
HELP QUIT
+1 ;
DELCMF(DA) ; check if cmf has entries tied to it
+1 IF $GET(DA)=""
QUIT 1
+2 NEW PSADEL,I,J
+3 SET (PSADEL,I)=0
+4 FOR
SET I=$ORDER(^PSD(58.35,I))
if 'I
QUIT
SET J=0
FOR
SET J=$ORDER(^PSD(58.35,I,"BAT",J))
if 'J
QUIT
IF $PIECE($GET(^PSD(58.35,I,"BAT",J,0)),"^",5)=+DA
SET PSADEL=1
+5 QUIT PSADEL
