- ACHSTX99 ; IHS/ITSC/PMF - copy export records for examination [ 10/16/2001 8:16 AM ]
- ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
- ;
- Q
- ;
- S DOLH=$G(DOLH) I DOLH="" S DOLH=$TR($H,",","_")
- S PMFCOUNT=$G(PMFCOUNT)+1
- ;
- I $G(ACHSDOCR)="" Q
- I $G(PMFF)="" S PMFF=$G(^ACHSDATA(ACHSRCT))
- ;
- I PMFF="" Q
- ;
- ;
- S PMFDIEN=$G(ACHSDIEN)
- ;
- I PMFDIEN="" S PMFDIEN=$G(P)
- I PMFDIEN="" S PMFDIEN=$G(R)
- ;
- ;for test
- ;I PMFDIEN="" W !,"no dien" R G Q
- ;
- ;
- S ^ACHSF(DUZ(2),"XPRT4",PMFDIEN,DOLH)=ACHSDOCR
- S ^ACHSF(DUZ(2),"XPRT4",PMFDIEN,DOLH,PMFF)=""
- ;
- S SDA=$G(SDA) I SDA="" S SDA="??"
- S ^ACHSF(DUZ(2),"XPRT8",PMFDIEN,SDA,DOLH,PMFCOUNT)=PMFF
- ;
- S PPMF=$E(PMFF)
- S ^ACHSF(DUZ(2),"XPRT7",PMFDIEN,DOLH)=$G(^ACHSF(DUZ(2),"XPRT7",PMFDIEN,DOLH))+1
- S ^ACHSF(DUZ(2),"XPRT7",PMFDIEN,DOLH,PPMF)=$G(^ACHSF(DUZ(2),"XPRT7",PMFDIEN,DOLH,PPMF))+1
- ;
- ;
- K PMFF,PPMF,PMFDIEN
- ;
- Q
- ;
- CLEAN ;
- N A,B,C,FAC,KILLH
- S KILLH=$H-7
- S FAC=0 F S FAC=$O(^ACHSF(FAC)) Q:FAC=""!'FAC D
- . S A="XPR" F S A=$O(^ACHSF(FAC,A)) Q:A="" Q:$E(A,1,3)'="XPR" D
- .. S B="" F S B=$O(^ACHSF(FAC,A,B)) Q:B="" D
- ... I A="XPRT",+B<KILLH K ^ACHSF(FAC,A,B) Q
- ... I A="XPRT" Q
- ... S C="" F S C=$O(^ACHSF(FAC,A,B,C)) Q:C="" D
- .... I +C<KILLH K ^ACHSF(FAC,A,B,C)
- .... Q
- ... Q
- .. Q
- . Q
- Q
- ACHSTX99 ; IHS/ITSC/PMF - copy export records for examination [ 10/16/2001 8:16 AM ]
- +1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
- +2 ;
- +3 QUIT
- +4 ;
- +5 SET DOLH=$GET(DOLH)
- IF DOLH=""
- SET DOLH=$TRANSLATE($HOROLOG,",","_")
- +6 SET PMFCOUNT=$GET(PMFCOUNT)+1
- +7 ;
- +8 IF $GET(ACHSDOCR)=""
- QUIT
- +9 IF $GET(PMFF)=""
- SET PMFF=$GET(^ACHSDATA(ACHSRCT))
- +10 ;
- +11 IF PMFF=""
- QUIT
- +12 ;
- +13 ;
- +14 SET PMFDIEN=$GET(ACHSDIEN)
- +15 ;
- +16 IF PMFDIEN=""
- SET PMFDIEN=$GET(P)
- +17 IF PMFDIEN=""
- SET PMFDIEN=$GET(R)
- +18 ;
- +19 ;for test
- +20 ;I PMFDIEN="" W !,"no dien" R G Q
- +21 ;
- +22 ;
- +23 SET ^ACHSF(DUZ(2),"XPRT4",PMFDIEN,DOLH)=ACHSDOCR
- +24 SET ^ACHSF(DUZ(2),"XPRT4",PMFDIEN,DOLH,PMFF)=""
- +25 ;
- +26 SET SDA=$GET(SDA)
- IF SDA=""
- SET SDA="??"
- +27 SET ^ACHSF(DUZ(2),"XPRT8",PMFDIEN,SDA,DOLH,PMFCOUNT)=PMFF
- +28 ;
- +29 SET PPMF=$EXTRACT(PMFF)
- +30 SET ^ACHSF(DUZ(2),"XPRT7",PMFDIEN,DOLH)=$GET(^ACHSF(DUZ(2),"XPRT7",PMFDIEN,DOLH))+1
- +31 SET ^ACHSF(DUZ(2),"XPRT7",PMFDIEN,DOLH,PPMF)=$GET(^ACHSF(DUZ(2),"XPRT7",PMFDIEN,DOLH,PPMF))+1
- +32 ;
- +33 ;
- +34 KILL PMFF,PPMF,PMFDIEN
- +35 ;
- +36 QUIT
- +37 ;
- CLEAN ;
- +1 NEW A,B,C,FAC,KILLH
- +2 SET KILLH=$HOROLOG-7
- +3 SET FAC=0
- FOR
- SET FAC=$ORDER(^ACHSF(FAC))
- IF FAC=""!'FAC
- QUIT
- Begin DoDot:1
- +4 SET A="XPR"
- FOR
- SET A=$ORDER(^ACHSF(FAC,A))
- IF A=""
- QUIT
- IF $EXTRACT(A,1,3)'="XPR"
- QUIT
- Begin DoDot:2
- +5 SET B=""
- FOR
- SET B=$ORDER(^ACHSF(FAC,A,B))
- IF B=""
- QUIT
- Begin DoDot:3
- +6 IF A="XPRT"
- IF +B<KILLH
- KILL ^ACHSF(FAC,A,B)
- QUIT
- +7 IF A="XPRT"
- QUIT
- +8 SET C=""
- FOR
- SET C=$ORDER(^ACHSF(FAC,A,B,C))
- IF C=""
- QUIT
- Begin DoDot:4
- +9 IF +C<KILLH
- KILL ^ACHSF(FAC,A,B,C)
- +10 QUIT
- End DoDot:4
- +11 QUIT
- End DoDot:3
- +12 QUIT
- End DoDot:2
- +13 QUIT
- End DoDot:1
- +14 QUIT
