ACHSUD ; IHS/ITSC/PMF - SELECT CHS DOCUMENT FOR DISPLAY ; [ 05/20/2003 1:56 PM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5**;JUN 11, 2001
;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Prevent <UNDEF> when Jumping.
;
;THE FOLLOWING LINES ARE A GALLANT ATTEMPT TO USE FILEMAN TO DO THE
;LOOKUP PROPERLY. HOWEVER IT DID NOT WORK. STRUCTURE OF THE DATA?????
;S DIC="^ACHSF("_DUZ(2)_"," ;"D"","
;S DIC(0)="AQEM",D="AC"
;B
;D MIX^DIC1
;W !,Y
;
;
;Q
;
ACHSUDOD ;
K ACHSDIEN,DIC,DA,D0
A1 ;
;
S Y=$$DIR^XBDIR("FO","Select Document","","","Enter the P.O. number or ""??"" for a list","^D Q1^ACHSUD",2)
Q:$D(DTOUT)!$D(DUOUT)!(Y="")
;FOLLOWING LINE TRIES TO DO SPACE RECOVER LAST ENTRY TYPE THING
I Y=" ",$D(^DISV(DUZ,"ACHSUD")) S Y=$G(^DISV(DUZ,"ACHSUD")),Y=$E(Y,2)_"-"_$E(Y,3,99) W Y
;
I Y?1.U.1",".U G NAME
F I=1:1:$L(Y) I $E(Y,I)?1P,$E(Y,I)'="-" S Y=$E(Y,1,I-1)_"-"_$E(Y,I+1,999)
F I=1:1 S F=$F(Y,"--") Q:'F S Y=$P(Y,"--")_"-"_$P(Y,"--",2,999)
S (N,F,C)="",P=$L(Y,"-")
I P>3 W *7," ??" G A1
S N=$P(Y,"-",P)
I P=3 S F=$P(Y,"-",2),C=+Y G A2
I P=2 S C=$P(Y,"-") S:$L(C)>1 F=C,C=""
A2 ;
S ACHSFC=$$FC^ACHS(DUZ(2)) ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
S:C="" C=$E(ACHSCFY,4)
S:F="" F=ACHSFC
I $L(F)<3 S F=$E("000",1,3-$L(F))_F
I $L(N)<6 S N=$E("00000",1,5-$L(N))_N
S X="1"_C_N
S DIC="^ACHSF("_DUZ(2)_",""D"","
S DIC(0)="QZE"
;S DIC("W")="W "" "",$P(^(0),U,14),""-"",ACHSFC,""-"",$P(^(0),U)"
A3 ;
D ^DIC
K DIC
G A1:Y<1
S ACHSDIEN=+Y
S ^DISV(DUZ,"ACHSUD")=$P(Y,U,2)
Q
;
NAME ; undocumented feature...too slow to publish.
N ACHSDUZ2
I $$PARM^ACHS(2,5)="Y" S ACHSDUZ2=DUZ(2),DUZ(2)=0
S DIC="^AUPNPAT(",DIC(0)="EMQ",AUPNLK("INAC")=""
S X=Y
D ^DIC
K DFN,DIC,AUPNLK("INAC")
I Y'<1 S DFN=+Y
I $G(ACHSDUZ2) S ACHSYAYA=42,DUZ(2)=ACHSDUZ2 K ACHSYAYA
Q:'$D(DFN)
S X="??",DIC(0)="E",DIC="^ACHSF("_DUZ(2)_",""D"",",DIC("W")="D Q3^ACHSUD",DIC("S")="I $P(^(0),U,22)=DFN"
G A3
;
;HELP SUBROUTINE FOR INITIAL DOCUMENT SELECT PROMPT AT A1+1
Q1 ;EP - From ^DIR.
; W !," Enter the Patient's Name, or"
W !!," Enter the 'Order Number' for the document",!," In the following format: F-LOC-NUMBER",!!," Where",!?12,"F",?20,"Is the one-digit fiscal year code",!?12,"LOC",?20,"Is the three-character financial location code"
W !?12,"NUMBER",?20,"Is The 5-digit document number",!!," You May Omit The First Two Items If You Wish",!," (Current Fiscal Year And Location Code Will Be Assumed)",!," Also, leading zeros on the document are OPTIONAL."
Q2 ;
I $$DIR^XBDIR("Y","Do you wish to see a list of documents","N","","","",2) D ;GET LISTING OF POSSIBLES
.K DIC
.S LISTCNT=$G(LISTCNT) I 'LISTCNT S LISTCNT=1 ;INITIALIZE LIST COUNTER
.S X="??",DIC(0)="ES",DIC="^ACHSF("_DUZ(2)_",""D"","
.S DIC("W")="D Q3^ACHSUD" ;USE THIS SUBRTN FOR LISTING CHOICES
.D ^DIC K DIC
Q
;
Q3 ;EP - From call to ^DIC. See line Q2+1.
;
S LISTCNT=$G(LISTCNT)+1
S DOCDATA=$G(^ACHSF(DUZ(2),"D",+Y,0)) ;DOCUMENT SUB FILE 0 NODE
;
;GET FINANCE CODE
S ACHSFC=$P($G(^AUTTLOC(DUZ(2),0)),U,17)
I $L(ACHSFC)'=3!(ACHSFC="") W !!,"SOMETHING WRONG WITH THIS FACILITY'S FINANCE CODE" W !!,"REPORT THIS TO YOUR SITE MANAGER IMMEDIATELY!!" D RTRN^ACHS Q
;
S:ACHSFC'="" ACHSFC=$P(^AUTTAREA($P(^AUTTLOC(DUZ(2),0),U,4),0),U,3)_$E(ACHSFC,2,3)
;
;WRITE FULL DOCUMENT NUMBER
W ?14,$P(DOCDATA,U,14),"-",ACHSFC,"-",$P(DOCDATA,U)_"("_+Y_")"
S ACHS=$P(DOCDATA,U,4) ;TYPE OF SERVICE
; '1' FOR 43 (HOSPITAL SERVICE);
; '2' FOR 57 (DENTAL SERVICE);
; '3' FOR 64 (OUTPATIENT SERVICE)
W ?30,$S(ACHS=1:"HOSPITAL",ACHS=2:"DENTAL",ACHS=3:"OUTPATIENT",1:"??")
;
S ACHS=$P(DOCDATA,U,12) ;STATUS
W ?45,$S(ACHS=0:"OPEN",ACHS=1:"SUPPLEMENTAL",ACHS=2:"PARTIAL CANCEL",ACHS=3:"PAID",ACHS=4:"CANCELED",1:"??")
;
;BLANKET ORDER
W:$P(DOCDATA,U,3) ?55,$S($P(DOCDATA,U,3)=1:"* BLANKET",$P(DOCDATA,U,3)=2:"* SPECIAL TRANS",1:"")
;
;
;WHY THIS LINE??
;I $D(^ACHSF(DUZ(2),"D",+Y,"T",1,0)),$P(^ACHSF(DUZ(2),"D",+Y,0),U,3),$D(^DPT(+$P(DOCDATA,U,3),0)) W ?75,$P(DOCDATA,U) ;
Q
;
SELTRANS(D) ;EP - Display trans of doc D, and allow selection.
N C,T
;
W !!?10,"----------------------------------------------------",!?10,"TRANS",?30,"TRANS",!?11,"NUM",?19,"D A T E",?30,"TYPE",?40,"AMOUNT",!?10,"----------------------------------------------------",!!
;
S (C,T)=0
F S T=$O(^ACHSF(DUZ(2),"D",D,"T",T)) Q:+T=0 S Y=$G(^ACHSF(DUZ(2),"D",D,"T",T,0)),C=C+1,C(C)=T W !?10,$J(C,3) D DISTRANS(D,T)
S Y=$$DIR^XBDIR("N^1:"_C,"Select a transaction","","","Enter the number corresponding to the transaction you want","",2)
Q:$D(DUOUT)!$D(DTOUT)!(Y=0) 0
Q C(Y)
;
DISTRANS(D,T) ;
S Y=$G(^ACHSF(DUZ(2),"D",D,"T",T,0))
W ?17,$$FMTE^XLFDT($P(Y,U,1)),?32,$P(Y,U,2),$P(Y,U,5),?35,$J($FN($P(Y,U,4),",",2),11)," <",$$EXTSET^XBFUNC(9002080.02,1,$P(Y,U,2)),">"
Q
;
ACHSUD ; IHS/ITSC/PMF - SELECT CHS DOCUMENT FOR DISPLAY ; [ 05/20/2003 1:56 PM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5**;JUN 11, 2001
+2 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Prevent <UNDEF> when Jumping.
+3 ;
+4 ;THE FOLLOWING LINES ARE A GALLANT ATTEMPT TO USE FILEMAN TO DO THE
+5 ;LOOKUP PROPERLY. HOWEVER IT DID NOT WORK. STRUCTURE OF THE DATA?????
+6 ;S DIC="^ACHSF("_DUZ(2)_"," ;"D"","
+7 ;S DIC(0)="AQEM",D="AC"
+8 ;B
+9 ;D MIX^DIC1
+10 ;W !,Y
+11 ;
+12 ;
+13 ;Q
+14 ;
ACHSUDOD ;
+1 KILL ACHSDIEN,DIC,DA,D0
A1 ;
+1 ;
+2 SET Y=$$DIR^XBDIR("FO","Select Document","","","Enter the P.O. number or ""??"" for a list","^D Q1^ACHSUD",2)
+3 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
QUIT
+4 ;FOLLOWING LINE TRIES TO DO SPACE RECOVER LAST ENTRY TYPE THING
+5 IF Y=" "
IF $DATA(^DISV(DUZ,"ACHSUD"))
SET Y=$GET(^DISV(DUZ,"ACHSUD"))
SET Y=$EXTRACT(Y,2)_"-"_$EXTRACT(Y,3,99)
WRITE Y
+6 ;
+7 IF Y?1.U.1",".U
GOTO NAME
+8 FOR I=1:1:$LENGTH(Y)
IF $EXTRACT(Y,I)?1P
IF $EXTRACT(Y,I)'="-"
SET Y=$EXTRACT(Y,1,I-1)_"-"_$EXTRACT(Y,I+1,999)
+9 FOR I=1:1
SET F=$FIND(Y,"--")
IF 'F
QUIT
SET Y=$PIECE(Y,"--")_"-"_$PIECE(Y,"--",2,999)
+10 SET (N,F,C)=""
SET P=$LENGTH(Y,"-")
+11 IF P>3
WRITE *7," ??"
GOTO A1
+12 SET N=$PIECE(Y,"-",P)
+13 IF P=3
SET F=$PIECE(Y,"-",2)
SET C=+Y
GOTO A2
+14 IF P=2
SET C=$PIECE(Y,"-")
IF $LENGTH(C)>1
SET F=C
SET C=""
A2 ;
+1 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
SET ACHSFC=$$FC^ACHS(DUZ(2))
+2 IF C=""
SET C=$EXTRACT(ACHSCFY,4)
+3 IF F=""
SET F=ACHSFC
+4 IF $LENGTH(F)<3
SET F=$EXTRACT("000",1,3-$LENGTH(F))_F
+5 IF $LENGTH(N)<6
SET N=$EXTRACT("00000",1,5-$LENGTH(N))_N
+6 SET X="1"_C_N
+7 SET DIC="^ACHSF("_DUZ(2)_",""D"","
+8 SET DIC(0)="QZE"
+9 ;S DIC("W")="W "" "",$P(^(0),U,14),""-"",ACHSFC,""-"",$P(^(0),U)"
A3 ;
+1 DO ^DIC
+2 KILL DIC
+3 IF Y<1
GOTO A1
+4 SET ACHSDIEN=+Y
+5 SET ^DISV(DUZ,"ACHSUD")=$PIECE(Y,U,2)
+6 QUIT
+7 ;
NAME ; undocumented feature...too slow to publish.
+1 NEW ACHSDUZ2
+2 IF $$PARM^ACHS(2,5)="Y"
SET ACHSDUZ2=DUZ(2)
SET DUZ(2)=0
+3 SET DIC="^AUPNPAT("
SET DIC(0)="EMQ"
SET AUPNLK("INAC")=""
+4 SET X=Y
+5 DO ^DIC
+6 KILL DFN,DIC,AUPNLK("INAC")
+7 IF Y'<1
SET DFN=+Y
+8 IF $GET(ACHSDUZ2)
SET ACHSYAYA=42
SET DUZ(2)=ACHSDUZ2
KILL ACHSYAYA
+9 IF '$DATA(DFN)
QUIT
+10 SET X="??"
SET DIC(0)="E"
SET DIC="^ACHSF("_DUZ(2)_",""D"","
SET DIC("W")="D Q3^ACHSUD"
SET DIC("S")="I $P(^(0),U,22)=DFN"
+11 GOTO A3
+12 ;
+13 ;HELP SUBROUTINE FOR INITIAL DOCUMENT SELECT PROMPT AT A1+1
Q1 ;EP - From ^DIR.
+1 ; W !," Enter the Patient's Name, or"
+2 WRITE !!," Enter the 'Order Number' for the document",!," In the following format: F-LOC-NUMBER",!!," Where",!?12,"F",?20,"Is the one-digit fiscal year code",!?12,"LOC",?20,"Is the three-character financial location code"
+3 WRITE !?12,"NUMBER",?20,"Is The 5-digit document number",!!," You May Omit The First Two Items If You Wish",!," (Current Fiscal Year And Location Code Will Be Assumed)",!," Also, leading zeros on the document are OPTIONAL."
Q2 ;
+1 ;GET LISTING OF POSSIBLES
IF $$DIR^XBDIR("Y","Do you wish to see a list of documents","N","","","",2)
Begin DoDot:1
+2 KILL DIC
+3 ;INITIALIZE LIST COUNTER
SET LISTCNT=$GET(LISTCNT)
IF 'LISTCNT
SET LISTCNT=1
+4 SET X="??"
SET DIC(0)="ES"
SET DIC="^ACHSF("_DUZ(2)_",""D"","
+5 ;USE THIS SUBRTN FOR LISTING CHOICES
SET DIC("W")="D Q3^ACHSUD"
+6 DO ^DIC
KILL DIC
End DoDot:1
+7 QUIT
+8 ;
Q3 ;EP - From call to ^DIC. See line Q2+1.
+1 ;
+2 SET LISTCNT=$GET(LISTCNT)+1
+3 ;DOCUMENT SUB FILE 0 NODE
SET DOCDATA=$GET(^ACHSF(DUZ(2),"D",+Y,0))
+4 ;
+5 ;GET FINANCE CODE
+6 SET ACHSFC=$PIECE($GET(^AUTTLOC(DUZ(2),0)),U,17)
+7 IF $LENGTH(ACHSFC)'=3!(ACHSFC="")
WRITE !!,"SOMETHING WRONG WITH THIS FACILITY'S FINANCE CODE"
WRITE !!,"REPORT THIS TO YOUR SITE MANAGER IMMEDIATELY!!"
DO RTRN^ACHS
QUIT
+8 ;
+9 IF ACHSFC'=""
SET ACHSFC=$PIECE(^AUTTAREA($PIECE(^AUTTLOC(DUZ(2),0),U,4),0),U,3)_$EXTRACT(ACHSFC,2,3)
+10 ;
+11 ;WRITE FULL DOCUMENT NUMBER
+12 WRITE ?14,$PIECE(DOCDATA,U,14),"-",ACHSFC,"-",$PIECE(DOCDATA,U)_"("_+Y_")"
+13 ;TYPE OF SERVICE
SET ACHS=$PIECE(DOCDATA,U,4)
+14 ; '1' FOR 43 (HOSPITAL SERVICE);
+15 ; '2' FOR 57 (DENTAL SERVICE);
+16 ; '3' FOR 64 (OUTPATIENT SERVICE)
+17 WRITE ?30,$SELECT(ACHS=1:"HOSPITAL",ACHS=2:"DENTAL",ACHS=3:"OUTPATIENT",1:"??")
+18 ;
+19 ;STATUS
SET ACHS=$PIECE(DOCDATA,U,12)
+20 WRITE ?45,$SELECT(ACHS=0:"OPEN",ACHS=1:"SUPPLEMENTAL",ACHS=2:"PARTIAL CANCEL",ACHS=3:"PAID",ACHS=4:"CANCELED",1:"??")
+21 ;
+22 ;BLANKET ORDER
+23 IF $PIECE(DOCDATA,U,3)
WRITE ?55,$SELECT($PIECE(DOCDATA,U,3)=1:"* BLANKET",$PIECE(DOCDATA,U,3)=2:"* SPECIAL TRANS",1:"")
+24 ;
+25 ;
+26 ;WHY THIS LINE??
+27 ;I $D(^ACHSF(DUZ(2),"D",+Y,"T",1,0)),$P(^ACHSF(DUZ(2),"D",+Y,0),U,3),$D(^DPT(+$P(DOCDATA,U,3),0)) W ?75,$P(DOCDATA,U) ;
+28 QUIT
+29 ;
SELTRANS(D) ;EP - Display trans of doc D, and allow selection.
+1 NEW C,T
+2 ;
+3 WRITE !!?10,"----------------------------------------------------",!?10,"TRANS",?30,"TRANS",!?11,"NUM",?19,"D A T E",?30,"TYPE",?40,"AMOUNT",!?10,"----------------------------------------------------",!!
+4 ;
+5 SET (C,T)=0
+6 FOR
SET T=$ORDER(^ACHSF(DUZ(2),"D",D,"T",T))
IF +T=0
QUIT
SET Y=$GET(^ACHSF(DUZ(2),"D",D,"T",T,0))
SET C=C+1
SET C(C)=T
WRITE !?10,$JUSTIFY(C,3)
DO DISTRANS(D,T)
+7 SET Y=$$DIR^XBDIR("N^1:"_C,"Select a transaction","","","Enter the number corresponding to the transaction you want","",2)
+8 IF $DATA(DUOUT)!$DATA(DTOUT)!(Y=0)
QUIT 0
+9 QUIT C(Y)
+10 ;
DISTRANS(D,T) ;
+1 SET Y=$GET(^ACHSF(DUZ(2),"D",D,"T",T,0))
+2 WRITE ?17,$$FMTE^XLFDT($PIECE(Y,U,1)),?32,$PIECE(Y,U,2),$PIECE(Y,U,5),?35,$JUSTIFY($FNUMBER($PIECE(Y,U,4),",",2),11)," <",$$EXTSET^XBFUNC(9002080.02,1,$PIECE(Y,U,2)),">"
+3 QUIT
+4 ;
