Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACHSUD

ACHSUD.m

Go to the documentation of this file. 
  1. 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
  1.  ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Prevent <UNDEF> when Jumping.
  1.  ;
  1.  ;THE FOLLOWING LINES ARE A GALLANT ATTEMPT TO USE FILEMAN TO DO THE
  1.  ;LOOKUP PROPERLY. HOWEVER IT DID NOT WORK. STRUCTURE OF THE DATA?????
  1.  ;S DIC="^ACHSF("_DUZ(2)_","    ;"D"","
  1.  ;S DIC(0)="AQEM",D="AC"
  1.  ;B
  1.  ;D MIX^DIC1
  1.  ;W !,Y
  1.  ;
  1.  ;
  1.  ;Q
  1.  ;
  1. ACHSUDOD ;
  1.  K ACHSDIEN,DIC,DA,D0
  1. A1 ;
  1.  ;
  1.  S Y=$$DIR^XBDIR("FO","Select Document","","","Enter the P.O. number or ""??"" for a list","^D Q1^ACHSUD",2)
  1.  Q:$D(DTOUT)!$D(DUOUT)!(Y="")
  1.  ;FOLLOWING LINE TRIES TO DO SPACE RECOVER LAST ENTRY TYPE THING
  1.  I Y=" ",$D(^DISV(DUZ,"ACHSUD")) S Y=$G(^DISV(DUZ,"ACHSUD")),Y=$E(Y,2)_"-"_$E(Y,3,99) W Y
  1.  ;
  1.  I Y?1.U.1",".U G NAME
  1.  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)
  1.  F I=1:1 S F=$F(Y,"--") Q:'F  S Y=$P(Y,"--")_"-"_$P(Y,"--",2,999)
  1.  S (N,F,C)="",P=$L(Y,"-")
  1.  I P>3 W *7,"  ??" G A1
  1.  S N=$P(Y,"-",P)
  1.  I P=3 S F=$P(Y,"-",2),C=+Y G A2
  1.  I P=2 S C=$P(Y,"-") S:$L(C)>1 F=C,C=""
  1. A2 ;
  1.  S ACHSFC=$$FC^ACHS(DUZ(2)) ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
  1.  S:C="" C=$E(ACHSCFY,4)
  1.  S:F="" F=ACHSFC
  1.  I $L(F)<3 S F=$E("000",1,3-$L(F))_F
  1.  I $L(N)<6 S N=$E("00000",1,5-$L(N))_N
  1.  S X="1"_C_N
  1.  S DIC="^ACHSF("_DUZ(2)_",""D"","
  1.  S DIC(0)="QZE"
  1.  ;S DIC("W")="W ""  "",$P(^(0),U,14),""-"",ACHSFC,""-"",$P(^(0),U)"
  1. A3 ;
  1.  D ^DIC
  1.  K DIC
  1.  G A1:Y<1
  1.  S ACHSDIEN=+Y
  1.  S ^DISV(DUZ,"ACHSUD")=$P(Y,U,2)
  1.  Q
  1.  ;
  1. NAME ; undocumented feature...too slow to publish.
  1.  N ACHSDUZ2
  1.  I $$PARM^ACHS(2,5)="Y" S ACHSDUZ2=DUZ(2),DUZ(2)=0
  1.  S DIC="^AUPNPAT(",DIC(0)="EMQ",AUPNLK("INAC")=""
  1.  S X=Y
  1.  D ^DIC
  1.  K DFN,DIC,AUPNLK("INAC")
  1.  I Y'<1 S DFN=+Y
  1.  I $G(ACHSDUZ2) S ACHSYAYA=42,DUZ(2)=ACHSDUZ2 K ACHSYAYA
  1.  Q:'$D(DFN)
  1.  S X="??",DIC(0)="E",DIC="^ACHSF("_DUZ(2)_",""D"",",DIC("W")="D Q3^ACHSUD",DIC("S")="I $P(^(0),U,22)=DFN"
  1.  G A3
  1.  ;
  1.  ;HELP SUBROUTINE FOR INITIAL DOCUMENT SELECT PROMPT AT A1+1
  1. Q1 ;EP - From ^DIR.
  1.  ; W !,"  Enter the Patient's Name, or"
  1.  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"
  1.  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."
  1. Q2 ;
  1.  I $$DIR^XBDIR("Y","Do you wish to see a list of documents","N","","","",2) D    ;GET LISTING OF POSSIBLES
  1.  .K DIC
  1.  .S LISTCNT=$G(LISTCNT) I 'LISTCNT S LISTCNT=1    ;INITIALIZE LIST COUNTER
  1.  .S X="??",DIC(0)="ES",DIC="^ACHSF("_DUZ(2)_",""D"","
  1.  .S DIC("W")="D Q3^ACHSUD"   ;USE THIS SUBRTN FOR LISTING CHOICES
  1.  .D ^DIC K DIC
  1.  Q
  1.  ;
  1. Q3 ;EP - From call to ^DIC.  See line Q2+1.
  1.  ;
  1.  S LISTCNT=$G(LISTCNT)+1
  1.  S DOCDATA=$G(^ACHSF(DUZ(2),"D",+Y,0))   ;DOCUMENT SUB FILE 0 NODE
  1.  ;
  1.  ;GET FINANCE CODE
  1.  S ACHSFC=$P($G(^AUTTLOC(DUZ(2),0)),U,17)
  1.  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
  1.  ;
  1.  S:ACHSFC'="" ACHSFC=$P(^AUTTAREA($P(^AUTTLOC(DUZ(2),0),U,4),0),U,3)_$E(ACHSFC,2,3)
  1.  ;
  1.  ;WRITE FULL DOCUMENT NUMBER
  1.  W ?14,$P(DOCDATA,U,14),"-",ACHSFC,"-",$P(DOCDATA,U)_"("_+Y_")"
  1.  S ACHS=$P(DOCDATA,U,4)     ;TYPE OF SERVICE
  1.  ;                          '1' FOR 43 (HOSPITAL SERVICE);
  1.  ;                          '2' FOR 57 (DENTAL SERVICE);
  1.  ;                          '3' FOR 64 (OUTPATIENT SERVICE)
  1.  W ?30,$S(ACHS=1:"HOSPITAL",ACHS=2:"DENTAL",ACHS=3:"OUTPATIENT",1:"??")
  1.  ;
  1.  S ACHS=$P(DOCDATA,U,12)       ;STATUS
  1.  W ?45,$S(ACHS=0:"OPEN",ACHS=1:"SUPPLEMENTAL",ACHS=2:"PARTIAL CANCEL",ACHS=3:"PAID",ACHS=4:"CANCELED",1:"??")
  1.  ;
  1.  ;BLANKET ORDER
  1.  W:$P(DOCDATA,U,3) ?55,$S($P(DOCDATA,U,3)=1:"* BLANKET",$P(DOCDATA,U,3)=2:"* SPECIAL TRANS",1:"")
  1.  ;
  1.  ;
  1.  ;WHY THIS LINE??
  1.  ;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) ;
  1.  Q
  1.  ;
  1. SELTRANS(D) ;EP - Display trans of doc D, and allow selection.
  1.  N C,T
  1.  ;
  1.  W !!?10,"----------------------------------------------------",!?10,"TRANS",?30,"TRANS",!?11,"NUM",?19,"D A T E",?30,"TYPE",?40,"AMOUNT",!?10,"----------------------------------------------------",!!
  1.  ;
  1.  S (C,T)=0
  1.  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)
  1.  S Y=$$DIR^XBDIR("N^1:"_C,"Select a transaction","","","Enter the number corresponding to the transaction you want","",2)
  1.  Q:$D(DUOUT)!$D(DTOUT)!(Y=0) 0
  1.  Q C(Y)
  1.  ;
  1. DISTRANS(D,T) ; 
  1.  S Y=$G(^ACHSF(DUZ(2),"D",D,"T",T,0))
  1.  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)),">"
  1.  Q
  1.  ;