BJPNAPI1 ;GDIT/HS/BEE-Prenatal Care Module API Calls (Cont.) ; 08 May 2012 12:00 PM
;;2.0;PRENATAL CARE MODULE;;Feb 24, 2015;Build 63
;
Q
;
VFADD(TARGET,PIPIEN,VIEN,APCDALVR) ;PEP - Add entry to the V OB file and update the PIP entry
;
;This API adds a new entry to the V OB (#9000010.43) file and also adds (or updates)
;the corresponding prenatal problem list (#90680.01) entry with the new information.
;The V OB file is a dynamic file, meaning it tracks the values of problems over time. Therefore,
;a NEW entry to this file is created WHENEVER a problem is added to a patient's PIP OR WHENEVER
;an UPDATE is made to that problem entry on the PIP. If an update and fields are not passed in,
;current values are used in the new entry.
;
;The only exception is that notes are stored across entries (to save space in resaving them each time).
;To see therefore ALL notes that have been entered for a problem on the PIP, you have to loop through
;ALL V OB entries relating to that patient's PIP problem and pull ALL of the notes in each.
;
;Input:
; PIPIEN - Pointer to prenatal problem list (#90680.01) entry - Null if NEW entry
; VIEN - Visit IEN
; APCDALVR - Array of entry values
; - ("APCDSMD") - Pointer to BJPN SNOMED TERMS (#90680.02) entry. *REQUIRED for NEW PIP entry
; - ("APCDPRI") - Priority (L-Low,M-Medium,H-High)
; - ("APCDSCO") - Scope (A-All Pregnancies,C-Current Pregnancy)
; - ("APCDSTS") - Status (A-Active,I-Inactive)
; - ("APCDEDD") - Definitive EDD - Internal FM format
; - ("APCDPTX") - Provider Text String
; - ("APCDPOV") - Visit Set as POV (1-Yes,""-No)
; - ("NOTE") - Note to be added
; - ("APCDDELD") - Problem Deleted Date/Time - Internal FM format
; - ("APCDDELB") - Problem Deleted By - DUZ value
; - ("APCDDELR") - Problem Delete Reason - (D-Duplicate,E-Entered in Error,O-Other)
; - ("APCDDELO") - Delete Reason - if other
;
;Output:
; TARGET - Piece 1 - 1-Success/0-Failure
; Piece 2 - PIPIEN
; Piece 3 - Error Message
;
NEW DFN,ADD,SMDTM,NOW,%,APCDVUPD,BJPNUPD,ERROR,IEN,EVDT,PPROV,PKIEN,APCDTMP
;
;Save current copy of APCDALVR
M APCDTMP=APCDALVR
;
;Input validation
S PIPIEN=$G(PIPIEN)
S PKIEN=$G(APCDALVR("APCDSMD"))
I PIPIEN="",PKIEN="" S @TARGET@(1,0)="0^^New PIP problem - Missing APCDPKL" G XVFADD
I $G(VIEN)="" S @TARGET@(1,0)="0^^Missing VIEN" G XVFADD
S DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I") I DFN="" S @TARGET@(1,0)="0^^Missing DFN" G XVFADD
;
D NOW^%DTC S NOW=%
;
;Set up additional APCDALVR entries
S APCDALVR("APCDPAT")=DFN
S APCDALVR("APCDVSIT")=VIEN
S APCDALVR("APCDATMP")="[APCDALVR 9000010.43 (MOD)]"
S APCDALVR("APCDAUTO")=1
S APCDALVR("AUPNTALK")=""
S APCDALVR("APCDLMD")=NOW
S:$D(APCDALVR("NOTE")) APCDVUPD(2100)=1
S APCDALVR("APCDEPV")=DUZ
;
;Determine if Add or Update - Look for UPDATE match if PIPIEN isn't passed
S ADD=0 S:PIPIEN="" ADD=1
I ADD=1 S IEN="" F S IEN=$O(^BJPNPL("AC",DFN,PKIEN,IEN)) Q:IEN="" D Q:'ADD
. ;
. ;Skip Deletes
. I $$GET1^DIQ(90680.01,IEN_",",2.01,"I")]""
. S ADD=0,PIPIEN=IEN
;
;If update, make sure it hasn't been deleted
I ADD=0,$$GET1^DIQ(90680.01,PIPIEN_",",2.01,"I")]"" S @TARGET@(1,0)="0^^Problem has been deleted - enter a new record (send PIPIEN as null)" G XVFADD
;
;Define Technical Note
I ADD=1 S APCDALVR("TNOTE")="Added Problem To PIP"
E S APCDALVR("TNOTE")="Updated Problem Entry"
;
;If Add - Create 90680.01 entry
I ADD=1 D I PIPIEN="" G XVFADD
. NEW DIC,DLAYGO,X,Y
. S DIC="^BJPNPL("
. S DLAYGO=90680.01,DIC("P")=DLAYGO,DIC(0)="LOX"
. S X=PKIEN
. S DIC("DR")=".02////"_DFN_";.03////"_PKIEN
. K DO,DD D FILE^DICN
. I Y=-1 S @TARGET@(1,0)="0^^Could not add problem to PIP" Q
. S PIPIEN=+Y
S APCDALVR("APCDPIP")=PIPIEN
;
;Get SNOMED Term
S SMDTM=$$GET1^DIQ(90680.02,PKIEN_",",.02,"E")
;
;Priority
I $D(APCDALVR("APCDPRI")) S APCDVUPD(.06)=""
I $D(APCDALVR("APCDPRI")),APCDALVR("APCDPRI")="" S APCDALVR("APCDPRI")="@"
I ADD=0,'$D(APCDALVR("APCDPRI")) S APCDALVR("APCDPRI")=$$GET1^DIQ(90680.01,PIPIEN_",",.06,"I")
;
;Provider Text
S:$G(APCDALVR("APCDPTX"))]"" APCDALVR("APCDPTX")=$$PNARR^BJPNVFIL(APCDALVR("APCDPTX")),APCDVUPD(.07)=""
I ADD=0,'$D(APCDALVR("APCDPTX")) S APCDALVR("APCDPTX")=$$GET1^DIQ(90680.01,PIPIEN_",",.05,"I")
;
;Provider Narrative
I $G(APCDALVR("APCDPTX"))]"" D
. NEW PTX
. S PTX=$$GET1^DIQ(9999999.27,APCDALVR("APCDPTX"),".01","E")
. S APCDALVR("APCDPNR")=$E(SMDTM_"| "_PTX,1,160)
. S APCDALVR("APCDPNR")=$$PNARR^BJPNVFIL(APCDALVR("APCDPNR"))
. S APCDVUPD(.11)=""
;
;Scope
I (ADD=1)!$D(APCDALVR("APCDSCO")) S APCDVUPD(.08)=""
I ADD=0,'$D(APCDALVR("APCDSCO")) S APCDALVR("APCDSCO")=$$GET1^DIQ(90680.01,PIPIEN_",",.07,"I")
I ADD=1,'$D(APCDALVR("APCDSCO")) S APCDALVR("APCDSCO")="C"
;
;Status
I (ADD=1)!$D(APCDALVR("APCDSTS")) S APCDVUPD(.09)=""
I ADD=0,'$D(APCDALVR("APCDSTS")) S APCDALVR("APCDSTS")=$$GET1^DIQ(90680.01,PIPIEN_",",.08,"I")
I ADD=1,'$D(APCDALVR("APCDSTS")) S APCDALVR("APCDSTS")="A"
;
;Definitive EDD
I (ADD=1)!$D(APCDALVR("APCDEDD")) S APCDVUPD(.1)=""
I ADD=0,'$D(APCDALVR("APCDEDD")) S APCDALVR("APCDEDD")=$$GET1^DIQ(90680.01,PIPIEN_",",.09,"I")
I ADD=1,'$D(APCDALVR("APCDEDD")) S APCDALVR("APCDEDD")=$$GET1^DIQ(9000017,DFN_",",1311,"I")
;
;Snomed Term
I (ADD=1)!$D(APCDALVR("APCDSMD")) S APCDVUPD(.12)=""
I ADD=0,'$D(APCDALVR("APCDSMD")) S APCDALVR("APCDSMD")=$$GET1^DIQ(90680.01,PIPIEN_",",.01,"I")
;
;Process Deletes
I $D(APCDALVR("APCDDELB")) S APCDVUPD(2.01)=""
I $D(APCDALVR("APCDDELD")) S APCDVUPD(2.02)=""
I $D(APCDALVR("APCDDELR")) S APCDVUPD(2.03)=""
I $D(APCDALVR("APCDDELO")) S APCDVUPD(2.04)=""
;
;Set as POV
I $D(APCDALVR("APCDPOV")) D
. S APCDVUPD(.05)=""
. I APCDALVR("APCDPOV")=1 Q
. I APCDALVR("APCDPOV")="" S APCDALVR("APCDPOV")="@"
;
;Original Entry Date/Entered By
I ADD=1 S APCDALVR("APCDOEDT")=NOW,APCDALVR("APCDOEBY")=DUZ,APCDVUPD(1216)="",APCDVUPD(1217)=""
E D
. S APCDALVR("APCDOEDT")=$$GET1^DIQ(90680.01,PIPIEN_",",1.01,"I")
. S APCDALVR("APCDOEBY")=$$GET1^DIQ(90680.01,PIPIEN_",",1.02,"I")
;
;Last Modified Date and By
S APCDALVR("APCDLMDT")=NOW
S APCDALVR("APCDLMBY")=DUZ
;
;1201 EVENT DATE AND TIME
S EVDT=$$GET1^DIQ(9000010,VIEN_",",.01,"I")
I EVDT]"" S APCDALVR("APCDEDT")=EVDT
;
;Ordering Provider
;S PPROV=$$PPRV^BJPNPKL(VIEN)
;I PPROV]"" S APCDALVR("APCDOPV")=PPROV
;
;Save Technical Notes
S APCDVUPD(1218)="",APCDVUPD(1219)=""
M APCDALVR("TNOTE")=APCDVUPD
;
;File V OB entry
D ^APCDALVR
I $G(APCDALVR("APCDAFLG"))=2 S @TARGET@(1,0)="0^^V OB file failed" G XVFADD
;
;Update Prenatal Problem entry
S:$G(APCDALVR("APCDSMD"))]"" BJPNUPD(90680.01,PIPIEN_",",.01)=APCDALVR("APCDSMD")
S:$G(APCDALVR("APCDPRI"))]"" BJPNUPD(90680.01,PIPIEN_",",.06)=APCDALVR("APCDPRI")
S:$G(APCDALVR("APCDSCO"))]"" BJPNUPD(90680.01,PIPIEN_",",.07)=APCDALVR("APCDSCO")
S:$G(APCDALVR("APCDSTS"))]"" BJPNUPD(90680.01,PIPIEN_",",.08)=APCDALVR("APCDSTS")
S:$G(APCDALVR("APCDEDD"))]"" BJPNUPD(90680.01,PIPIEN_",",.09)=APCDALVR("APCDEDD")
S:$G(APCDALVR("APCDPTX"))]"" BJPNUPD(90680.01,PIPIEN_",",.05)=APCDALVR("APCDPTX")
S:$G(APCDALVR("APCDOEDT"))]"" BJPNUPD(90680.01,PIPIEN_",",1.01)=APCDALVR("APCDOEDT")
S:$G(APCDALVR("APCDOEBY"))]"" BJPNUPD(90680.01,PIPIEN_",",1.02)=APCDALVR("APCDOEBY")
S:$G(APCDALVR("APCDDELD"))]"" BJPNUPD(90680.01,PIPIEN_",",2.01)=APCDALVR("APCDDELD")
S:$G(APCDALVR("APCDDELB"))]"" BJPNUPD(90680.01,PIPIEN_",",2.02)=APCDALVR("APCDDELB")
S:$G(APCDALVR("APCDDELR"))]"" BJPNUPD(90680.01,PIPIEN_",",2.03)=APCDALVR("APCDDELR")
S:$G(APCDALVR("APCDDELO"))]"" BJPNUPD(90680.01,PIPIEN_",",2.04)=APCDALVR("APCDDELO")
S:$G(APCDALVR("NOTE"))]"" BJPNUPD(90680.01,PIPIEN_",",3)=APCDALVR("NOTE")
S BJPNUPD(90680.01,PIPIEN_",",1.03)=NOW
S BJPNUPD(90680.01,PIPIEN_",",1.04)=DUZ
;
I $D(BJPNUPD) D FILE^DIE("","BJPNUPD","ERROR")
I $D(ERROR) S @TARGET@(1,0)="0^^File 90680.01 update failed" G XVFADD
;
;Set as POV
I $D(APCDALVR("APCDPOV")) D
. I APCDALVR("APCDPOV")=1 D POV^BJPNPUP("",VIEN,PIPIEN) Q
. I APCDALVR("APCDPOV")="" D DPOV^BJPNPUTL("",VIEN,PIPIEN)
;
S @TARGET@(1,0)="1^"_PIPIEN_"^"
;
XVFADD ;Restore original APCDALVR
K APCDALVR M APCDALVR=APCDTMP
Q "~@"_$NA(@TARGET)
;
PROC(PRBIEN,BPIEN,ASTS,PARM,PCNT,II,TYPE,TMP,RESULT) ;EP - Process one entry
;
;Called from APIP^BJPNAPI
;
NEW DEL,STRM,PNR,OEDT,OEBY,CNT,WRAP,PDSP,STS,LINE,BGO,SMD
NEW X1,X2,BRNG,ERNG,X,DEDD,API,NVDT,NPDT,NHYP,NEDT,SPACE
;
S $P(SPACE," ",80)=" "
S PARM=$G(PARM)
;
;Definitive EDD date range check
D GETPAR^CIAVMRPC(.NEDT,"BJPN POST DEDD DAYS","SYS",1,"I","")
;
;If blank default to 70
I +$G(NEDT)<1 S NEDT=70
;
;Define formatting parameters
S NVDT=$S(PARM["V":1,1:"")
S NPDT=$S(PARM["P":1,1:"")
S NHYP=$S(PARM["H":1,1:"")
;
;Skip deletes
S DEL=$$GET1^DIQ(90680.01,BPIEN_",",2.01,"I") Q:DEL]""
S DEL=$$GET1^DIQ(9000011,PRBIEN_",",2.02,"I") I DEL]"" Q ;IPL Delete
;
;Retrieve the entry from the API results
S BGO=$O(@TMP@("P",PRBIEN,"")) Q:BGO="" ;Quit if no IPL entry
S API=$G(@TMP@("P",PRBIEN,BGO)) Q:API=""
;
;Status - Active Only
S STS=$$GET1^DIQ(90680.01,BPIEN_",",.08,"I")
I '$G(ASTS),STS'="A" Q
;
;Provider Text
S PNR=$P(API,U,8)
;
;Tack on Inactive
I STS'="A" S PNR="(i)"_PNR
;
;Original Entry Date
S OEDT=$$FMTE^XLFDT($$GET1^DIQ(9000011,PRBIEN_",",.08,"I"),"2D")
;
;Original Entry By
S OEBY=$$GET1^DIQ(9000011,PRBIEN_",",1.03,"E")
;
;Problem Count
S PCNT=$G(PCNT)+1 I PCNT>1 S II=II+1,RESULT(II)=" "
S PDSP=PCNT_") ",PDSP=$E(PDSP,1,4)
;
;Handle Wrapping
D WRAP^BJPNPRNT(.WRAP,PNR,76)
;
;Process each wrapped line
S WRAP="" F LINE=1:1 S WRAP=$O(WRAP(WRAP)) Q:WRAP="" D
. S II=II+1,RESULT(II)=$S(LINE=1:PDSP,1:($E(SPACE,1,4)))_WRAP(WRAP)
;
;Tack on Date/By
S II=II+1,RESULT(II)=$E(SPACE,1,5)_"(Entered"_$S(NPDT:"",1:" "_OEDT)_$S(OEBY]"":" by ",1:"")_OEBY_")"
;
;Pull Definitive EDD
S DEDD=$$GET1^DIQ(90680.01,BPIEN_",",.09,"I")
S X1=DEDD,X2=-280 D C^%DTC S BRNG=X
S X1=DEDD,X2=NEDT D C^%DTC S ERNG=X
;
;Loop through Visit Instructions (Return All)
S BGO="" F S BGO=$O(@TMP@("I",PRBIEN,BGO)) Q:BGO="" D
. ;
. NEW APIRES,NIEN,IENS,DA,SCO,WRAP
. NEW DTTM,MDBY,ILMBY,NOTE,NSTS,SIGN,VSIT
. ;
. S SIGN=""
. S APIRES=$G(@TMP@("I",PRBIEN,BGO,0)) Q:APIRES=""
. ;
. ;Get note date/time entered and by
. S (DTTM,ILMBY)=""
. ;
. ;Note IEN
. S NIEN=$P(APIRES,U,2) Q:NIEN=""
. ;
. ;Get note date/time entered and by - V VISIT INSTRUCTIONS
. S (DTTM,ILMBY)=""
. S DTTM=$$GET1^DIQ(9000010.58,NIEN_",",1216,"I")
. S ILMBY=$$GET1^DIQ(9000010.58,NIEN_",",1217,"I")
. S SIGN=$P(APIRES,U,13)
. ;
. Q:DTTM=""
. S MDBY=$$GET1^DIQ(200,ILMBY_",",".01","E")
. ;
. ;Get Note
. S NOTE=$P($G(@TMP@("I",PRBIEN,BGO,1)),U,2)
. Q:NOTE=""
. ;
. ;Note Status
. S NSTS="A"
. I DEDD]"",DTTM'<BRNG,DTTM'>ERNG S NSTS="C"
. S NSTS=$S(VIEN]"":" ",TYPE="C":" ",1:" ("_NSTS_") ")
. ;
. ;Determined signed/unsigned
. S SIGN=$S(SIGN]"":"S",1:"U") Q:SIGN="U"
. ;
. ;Set up record
. ;
. ;Handle Wrapping
. D WRAP^BJPNPRNT(.WRAP,$S(NHYP:"",1:"-")_NSTS_NOTE_" ("_$S('NVDT:$$FMTE^XLFDT(DTTM,"2D")_" ",1:"")_$S(MDBY]"":"by ",1:"")_MDBY_")",72,2)
. ;
. ;Process each wrapped line
. S WRAP="" F LINE=1:1 S WRAP=$O(WRAP(WRAP)) Q:WRAP="" D
.. S II=II+1,RESULT(II)=$E(SPACE,1,5)_WRAP(WRAP)
;
Q
BJPNAPI1 ;GDIT/HS/BEE-Prenatal Care Module API Calls (Cont.) ; 08 May 2012 12:00 PM
+1 ;;2.0;PRENATAL CARE MODULE;;Feb 24, 2015;Build 63
+2 ;
+3 QUIT
+4 ;
VFADD(TARGET,PIPIEN,VIEN,APCDALVR) ;PEP - Add entry to the V OB file and update the PIP entry
+1 ;
+2 ;This API adds a new entry to the V OB (#9000010.43) file and also adds (or updates)
+3 ;the corresponding prenatal problem list (#90680.01) entry with the new information.
+4 ;The V OB file is a dynamic file, meaning it tracks the values of problems over time. Therefore,
+5 ;a NEW entry to this file is created WHENEVER a problem is added to a patient's PIP OR WHENEVER
+6 ;an UPDATE is made to that problem entry on the PIP. If an update and fields are not passed in,
+7 ;current values are used in the new entry.
+8 ;
+9 ;The only exception is that notes are stored across entries (to save space in resaving them each time).
+10 ;To see therefore ALL notes that have been entered for a problem on the PIP, you have to loop through
+11 ;ALL V OB entries relating to that patient's PIP problem and pull ALL of the notes in each.
+12 ;
+13 ;Input:
+14 ; PIPIEN - Pointer to prenatal problem list (#90680.01) entry - Null if NEW entry
+15 ; VIEN - Visit IEN
+16 ; APCDALVR - Array of entry values
+17 ; - ("APCDSMD") - Pointer to BJPN SNOMED TERMS (#90680.02) entry. *REQUIRED for NEW PIP entry
+18 ; - ("APCDPRI") - Priority (L-Low,M-Medium,H-High)
+19 ; - ("APCDSCO") - Scope (A-All Pregnancies,C-Current Pregnancy)
+20 ; - ("APCDSTS") - Status (A-Active,I-Inactive)
+21 ; - ("APCDEDD") - Definitive EDD - Internal FM format
+22 ; - ("APCDPTX") - Provider Text String
+23 ; - ("APCDPOV") - Visit Set as POV (1-Yes,""-No)
+24 ; - ("NOTE") - Note to be added
+25 ; - ("APCDDELD") - Problem Deleted Date/Time - Internal FM format
+26 ; - ("APCDDELB") - Problem Deleted By - DUZ value
+27 ; - ("APCDDELR") - Problem Delete Reason - (D-Duplicate,E-Entered in Error,O-Other)
+28 ; - ("APCDDELO") - Delete Reason - if other
+29 ;
+30 ;Output:
+31 ; TARGET - Piece 1 - 1-Success/0-Failure
+32 ; Piece 2 - PIPIEN
+33 ; Piece 3 - Error Message
+34 ;
+35 NEW DFN,ADD,SMDTM,NOW,%,APCDVUPD,BJPNUPD,ERROR,IEN,EVDT,PPROV,PKIEN,APCDTMP
+36 ;
+37 ;Save current copy of APCDALVR
+38 MERGE APCDTMP=APCDALVR
+39 ;
+40 ;Input validation
+41 SET PIPIEN=$GET(PIPIEN)
+42 SET PKIEN=$GET(APCDALVR("APCDSMD"))
+43 IF PIPIEN=""
IF PKIEN=""
SET @TARGET@(1,0)="0^^New PIP problem - Missing APCDPKL"
GOTO XVFADD
+44 IF $GET(VIEN)=""
SET @TARGET@(1,0)="0^^Missing VIEN"
GOTO XVFADD
+45 SET DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I")
IF DFN=""
SET @TARGET@(1,0)="0^^Missing DFN"
GOTO XVFADD
+46 ;
+47 DO NOW^%DTC
SET NOW=%
+48 ;
+49 ;Set up additional APCDALVR entries
+50 SET APCDALVR("APCDPAT")=DFN
+51 SET APCDALVR("APCDVSIT")=VIEN
+52 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.43 (MOD)]"
+53 SET APCDALVR("APCDAUTO")=1
+54 SET APCDALVR("AUPNTALK")=""
+55 SET APCDALVR("APCDLMD")=NOW
+56 IF $DATA(APCDALVR("NOTE"))
SET APCDVUPD(2100)=1
+57 SET APCDALVR("APCDEPV")=DUZ
+58 ;
+59 ;Determine if Add or Update - Look for UPDATE match if PIPIEN isn't passed
+60 SET ADD=0
IF PIPIEN=""
SET ADD=1
+61 IF ADD=1
SET IEN=""
FOR
SET IEN=$ORDER(^BJPNPL("AC",DFN,PKIEN,IEN))
IF IEN=""
QUIT
Begin DoDot:1
+62 ;
+63 ;Skip Deletes
+64 IF $$GET1^DIQ(90680.01,IEN_",",2.01,"I")]""
+65 SET ADD=0
SET PIPIEN=IEN
End DoDot:1
IF 'ADD
QUIT
+66 ;
+67 ;If update, make sure it hasn't been deleted
+68 IF ADD=0
IF $$GET1^DIQ(90680.01,PIPIEN_",",2.01,"I")]""
SET @TARGET@(1,0)="0^^Problem has been deleted - enter a new record (send PIPIEN as null)"
GOTO XVFADD
+69 ;
+70 ;Define Technical Note
+71 IF ADD=1
SET APCDALVR("TNOTE")="Added Problem To PIP"
+72 IF '$TEST
SET APCDALVR("TNOTE")="Updated Problem Entry"
+73 ;
+74 ;If Add - Create 90680.01 entry
+75 IF ADD=1
Begin DoDot:1
+76 NEW DIC,DLAYGO,X,Y
+77 SET DIC="^BJPNPL("
+78 SET DLAYGO=90680.01
SET DIC("P")=DLAYGO
SET DIC(0)="LOX"
+79 SET X=PKIEN
+80 SET DIC("DR")=".02////"_DFN_";.03////"_PKIEN
+81 KILL DO,DD
DO FILE^DICN
+82 IF Y=-1
SET @TARGET@(1,0)="0^^Could not add problem to PIP"
QUIT
+83 SET PIPIEN=+Y
End DoDot:1
IF PIPIEN=""
GOTO XVFADD
+84 SET APCDALVR("APCDPIP")=PIPIEN
+85 ;
+86 ;Get SNOMED Term
+87 SET SMDTM=$$GET1^DIQ(90680.02,PKIEN_",",.02,"E")
+88 ;
+89 ;Priority
+90 IF $DATA(APCDALVR("APCDPRI"))
SET APCDVUPD(.06)=""
+91 IF $DATA(APCDALVR("APCDPRI"))
IF APCDALVR("APCDPRI")=""
SET APCDALVR("APCDPRI")="@"
+92 IF ADD=0
IF '$DATA(APCDALVR("APCDPRI"))
SET APCDALVR("APCDPRI")=$$GET1^DIQ(90680.01,PIPIEN_",",.06,"I")
+93 ;
+94 ;Provider Text
+95 IF $GET(APCDALVR("APCDPTX"))]""
SET APCDALVR("APCDPTX")=$$PNARR^BJPNVFIL(APCDALVR("APCDPTX"))
SET APCDVUPD(.07)=""
+96 IF ADD=0
IF '$DATA(APCDALVR("APCDPTX"))
SET APCDALVR("APCDPTX")=$$GET1^DIQ(90680.01,PIPIEN_",",.05,"I")
+97 ;
+98 ;Provider Narrative
+99 IF $GET(APCDALVR("APCDPTX"))]""
Begin DoDot:1
+100 NEW PTX
+101 SET PTX=$$GET1^DIQ(9999999.27,APCDALVR("APCDPTX"),".01","E")
+102 SET APCDALVR("APCDPNR")=$EXTRACT(SMDTM_"| "_PTX,1,160)
+103 SET APCDALVR("APCDPNR")=$$PNARR^BJPNVFIL(APCDALVR("APCDPNR"))
+104 SET APCDVUPD(.11)=""
End DoDot:1
+105 ;
+106 ;Scope
+107 IF (ADD=1)!$DATA(APCDALVR("APCDSCO"))
SET APCDVUPD(.08)=""
+108 IF ADD=0
IF '$DATA(APCDALVR("APCDSCO"))
SET APCDALVR("APCDSCO")=$$GET1^DIQ(90680.01,PIPIEN_",",.07,"I")
+109 IF ADD=1
IF '$DATA(APCDALVR("APCDSCO"))
SET APCDALVR("APCDSCO")="C"
+110 ;
+111 ;Status
+112 IF (ADD=1)!$DATA(APCDALVR("APCDSTS"))
SET APCDVUPD(.09)=""
+113 IF ADD=0
IF '$DATA(APCDALVR("APCDSTS"))
SET APCDALVR("APCDSTS")=$$GET1^DIQ(90680.01,PIPIEN_",",.08,"I")
+114 IF ADD=1
IF '$DATA(APCDALVR("APCDSTS"))
SET APCDALVR("APCDSTS")="A"
+115 ;
+116 ;Definitive EDD
+117 IF (ADD=1)!$DATA(APCDALVR("APCDEDD"))
SET APCDVUPD(.1)=""
+118 IF ADD=0
IF '$DATA(APCDALVR("APCDEDD"))
SET APCDALVR("APCDEDD")=$$GET1^DIQ(90680.01,PIPIEN_",",.09,"I")
+119 IF ADD=1
IF '$DATA(APCDALVR("APCDEDD"))
SET APCDALVR("APCDEDD")=$$GET1^DIQ(9000017,DFN_",",1311,"I")
+120 ;
+121 ;Snomed Term
+122 IF (ADD=1)!$DATA(APCDALVR("APCDSMD"))
SET APCDVUPD(.12)=""
+123 IF ADD=0
IF '$DATA(APCDALVR("APCDSMD"))
SET APCDALVR("APCDSMD")=$$GET1^DIQ(90680.01,PIPIEN_",",.01,"I")
+124 ;
+125 ;Process Deletes
+126 IF $DATA(APCDALVR("APCDDELB"))
SET APCDVUPD(2.01)=""
+127 IF $DATA(APCDALVR("APCDDELD"))
SET APCDVUPD(2.02)=""
+128 IF $DATA(APCDALVR("APCDDELR"))
SET APCDVUPD(2.03)=""
+129 IF $DATA(APCDALVR("APCDDELO"))
SET APCDVUPD(2.04)=""
+130 ;
+131 ;Set as POV
+132 IF $DATA(APCDALVR("APCDPOV"))
Begin DoDot:1
+133 SET APCDVUPD(.05)=""
+134 IF APCDALVR("APCDPOV")=1
QUIT
+135 IF APCDALVR("APCDPOV")=""
SET APCDALVR("APCDPOV")="@"
End DoDot:1
+136 ;
+137 ;Original Entry Date/Entered By
+138 IF ADD=1
SET APCDALVR("APCDOEDT")=NOW
SET APCDALVR("APCDOEBY")=DUZ
SET APCDVUPD(1216)=""
SET APCDVUPD(1217)=""
+139 IF '$TEST
Begin DoDot:1
+140 SET APCDALVR("APCDOEDT")=$$GET1^DIQ(90680.01,PIPIEN_",",1.01,"I")
+141 SET APCDALVR("APCDOEBY")=$$GET1^DIQ(90680.01,PIPIEN_",",1.02,"I")
End DoDot:1
+142 ;
+143 ;Last Modified Date and By
+144 SET APCDALVR("APCDLMDT")=NOW
+145 SET APCDALVR("APCDLMBY")=DUZ
+146 ;
+147 ;1201 EVENT DATE AND TIME
+148 SET EVDT=$$GET1^DIQ(9000010,VIEN_",",.01,"I")
+149 IF EVDT]""
SET APCDALVR("APCDEDT")=EVDT
+150 ;
+151 ;Ordering Provider
+152 ;S PPROV=$$PPRV^BJPNPKL(VIEN)
+153 ;I PPROV]"" S APCDALVR("APCDOPV")=PPROV
+154 ;
+155 ;Save Technical Notes
+156 SET APCDVUPD(1218)=""
SET APCDVUPD(1219)=""
+157 MERGE APCDALVR("TNOTE")=APCDVUPD
+158 ;
+159 ;File V OB entry
+160 DO ^APCDALVR
+161 IF $GET(APCDALVR("APCDAFLG"))=2
SET @TARGET@(1,0)="0^^V OB file failed"
GOTO XVFADD
+162 ;
+163 ;Update Prenatal Problem entry
+164 IF $GET(APCDALVR("APCDSMD"))]""
SET BJPNUPD(90680.01,PIPIEN_",",.01)=APCDALVR("APCDSMD")
+165 IF $GET(APCDALVR("APCDPRI"))]""
SET BJPNUPD(90680.01,PIPIEN_",",.06)=APCDALVR("APCDPRI")
+166 IF $GET(APCDALVR("APCDSCO"))]""
SET BJPNUPD(90680.01,PIPIEN_",",.07)=APCDALVR("APCDSCO")
+167 IF $GET(APCDALVR("APCDSTS"))]""
SET BJPNUPD(90680.01,PIPIEN_",",.08)=APCDALVR("APCDSTS")
+168 IF $GET(APCDALVR("APCDEDD"))]""
SET BJPNUPD(90680.01,PIPIEN_",",.09)=APCDALVR("APCDEDD")
+169 IF $GET(APCDALVR("APCDPTX"))]""
SET BJPNUPD(90680.01,PIPIEN_",",.05)=APCDALVR("APCDPTX")
+170 IF $GET(APCDALVR("APCDOEDT"))]""
SET BJPNUPD(90680.01,PIPIEN_",",1.01)=APCDALVR("APCDOEDT")
+171 IF $GET(APCDALVR("APCDOEBY"))]""
SET BJPNUPD(90680.01,PIPIEN_",",1.02)=APCDALVR("APCDOEBY")
+172 IF $GET(APCDALVR("APCDDELD"))]""
SET BJPNUPD(90680.01,PIPIEN_",",2.01)=APCDALVR("APCDDELD")
+173 IF $GET(APCDALVR("APCDDELB"))]""
SET BJPNUPD(90680.01,PIPIEN_",",2.02)=APCDALVR("APCDDELB")
+174 IF $GET(APCDALVR("APCDDELR"))]""
SET BJPNUPD(90680.01,PIPIEN_",",2.03)=APCDALVR("APCDDELR")
+175 IF $GET(APCDALVR("APCDDELO"))]""
SET BJPNUPD(90680.01,PIPIEN_",",2.04)=APCDALVR("APCDDELO")
+176 IF $GET(APCDALVR("NOTE"))]""
SET BJPNUPD(90680.01,PIPIEN_",",3)=APCDALVR("NOTE")
+177 SET BJPNUPD(90680.01,PIPIEN_",",1.03)=NOW
+178 SET BJPNUPD(90680.01,PIPIEN_",",1.04)=DUZ
+179 ;
+180 IF $DATA(BJPNUPD)
DO FILE^DIE("","BJPNUPD","ERROR")
+181 IF $DATA(ERROR)
SET @TARGET@(1,0)="0^^File 90680.01 update failed"
GOTO XVFADD
+182 ;
+183 ;Set as POV
+184 IF $DATA(APCDALVR("APCDPOV"))
Begin DoDot:1
+185 IF APCDALVR("APCDPOV")=1
DO POV^BJPNPUP("",VIEN,PIPIEN)
QUIT
+186 IF APCDALVR("APCDPOV")=""
DO DPOV^BJPNPUTL("",VIEN,PIPIEN)
End DoDot:1
+187 ;
+188 SET @TARGET@(1,0)="1^"_PIPIEN_"^"
+189 ;
XVFADD ;Restore original APCDALVR
+1 KILL APCDALVR
MERGE APCDALVR=APCDTMP
+2 QUIT "~@"_$NAME(@TARGET)
+3 ;
PROC(PRBIEN,BPIEN,ASTS,PARM,PCNT,II,TYPE,TMP,RESULT) ;EP - Process one entry
+1 ;
+2 ;Called from APIP^BJPNAPI
+3 ;
+4 NEW DEL,STRM,PNR,OEDT,OEBY,CNT,WRAP,PDSP,STS,LINE,BGO,SMD
+5 NEW X1,X2,BRNG,ERNG,X,DEDD,API,NVDT,NPDT,NHYP,NEDT,SPACE
+6 ;
+7 SET $PIECE(SPACE," ",80)=" "
+8 SET PARM=$GET(PARM)
+9 ;
+10 ;Definitive EDD date range check
+11 DO GETPAR^CIAVMRPC(.NEDT,"BJPN POST DEDD DAYS","SYS",1,"I","")
+12 ;
+13 ;If blank default to 70
+14 IF +$GET(NEDT)<1
SET NEDT=70
+15 ;
+16 ;Define formatting parameters
+17 SET NVDT=$SELECT(PARM["V":1,1:"")
+18 SET NPDT=$SELECT(PARM["P":1,1:"")
+19 SET NHYP=$SELECT(PARM["H":1,1:"")
+20 ;
+21 ;Skip deletes
+22 SET DEL=$$GET1^DIQ(90680.01,BPIEN_",",2.01,"I")
IF DEL]""
QUIT
+23 ;IPL Delete
SET DEL=$$GET1^DIQ(9000011,PRBIEN_",",2.02,"I")
IF DEL]""
QUIT
+24 ;
+25 ;Retrieve the entry from the API results
+26 ;Quit if no IPL entry
SET BGO=$ORDER(@TMP@("P",PRBIEN,""))
IF BGO=""
QUIT
+27 SET API=$GET(@TMP@("P",PRBIEN,BGO))
IF API=""
QUIT
+28 ;
+29 ;Status - Active Only
+30 SET STS=$$GET1^DIQ(90680.01,BPIEN_",",.08,"I")
+31 IF '$GET(ASTS)
IF STS'="A"
QUIT
+32 ;
+33 ;Provider Text
+34 SET PNR=$PIECE(API,U,8)
+35 ;
+36 ;Tack on Inactive
+37 IF STS'="A"
SET PNR="(i)"_PNR
+38 ;
+39 ;Original Entry Date
+40 SET OEDT=$$FMTE^XLFDT($$GET1^DIQ(9000011,PRBIEN_",",.08,"I"),"2D")
+41 ;
+42 ;Original Entry By
+43 SET OEBY=$$GET1^DIQ(9000011,PRBIEN_",",1.03,"E")
+44 ;
+45 ;Problem Count
+46 SET PCNT=$GET(PCNT)+1
IF PCNT>1
SET II=II+1
SET RESULT(II)=" "
+47 SET PDSP=PCNT_") "
SET PDSP=$EXTRACT(PDSP,1,4)
+48 ;
+49 ;Handle Wrapping
+50 DO WRAP^BJPNPRNT(.WRAP,PNR,76)
+51 ;
+52 ;Process each wrapped line
+53 SET WRAP=""
FOR LINE=1:1
SET WRAP=$ORDER(WRAP(WRAP))
IF WRAP=""
QUIT
Begin DoDot:1
+54 SET II=II+1
SET RESULT(II)=$SELECT(LINE=1:PDSP,1:($EXTRACT(SPACE,1,4)))_WRAP(WRAP)
End DoDot:1
+55 ;
+56 ;Tack on Date/By
+57 SET II=II+1
SET RESULT(II)=$EXTRACT(SPACE,1,5)_"(Entered"_$SELECT(NPDT:"",1:" "_OEDT)_$SELECT(OEBY]"":" by ",1:"")_OEBY_")"
+58 ;
+59 ;Pull Definitive EDD
+60 SET DEDD=$$GET1^DIQ(90680.01,BPIEN_",",.09,"I")
+61 SET X1=DEDD
SET X2=-280
DO C^%DTC
SET BRNG=X
+62 SET X1=DEDD
SET X2=NEDT
DO C^%DTC
SET ERNG=X
+63 ;
+64 ;Loop through Visit Instructions (Return All)
+65 SET BGO=""
FOR
SET BGO=$ORDER(@TMP@("I",PRBIEN,BGO))
IF BGO=""
QUIT
Begin DoDot:1
+66 ;
+67 NEW APIRES,NIEN,IENS,DA,SCO,WRAP
+68 NEW DTTM,MDBY,ILMBY,NOTE,NSTS,SIGN,VSIT
+69 ;
+70 SET SIGN=""
+71 SET APIRES=$GET(@TMP@("I",PRBIEN,BGO,0))
IF APIRES=""
QUIT
+72 ;
+73 ;Get note date/time entered and by
+74 SET (DTTM,ILMBY)=""
+75 ;
+76 ;Note IEN
+77 SET NIEN=$PIECE(APIRES,U,2)
IF NIEN=""
QUIT
+78 ;
+79 ;Get note date/time entered and by - V VISIT INSTRUCTIONS
+80 SET (DTTM,ILMBY)=""
+81 SET DTTM=$$GET1^DIQ(9000010.58,NIEN_",",1216,"I")
+82 SET ILMBY=$$GET1^DIQ(9000010.58,NIEN_",",1217,"I")
+83 SET SIGN=$PIECE(APIRES,U,13)
+84 ;
+85 IF DTTM=""
QUIT
+86 SET MDBY=$$GET1^DIQ(200,ILMBY_",",".01","E")
+87 ;
+88 ;Get Note
+89 SET NOTE=$PIECE($GET(@TMP@("I",PRBIEN,BGO,1)),U,2)
+90 IF NOTE=""
QUIT
+91 ;
+92 ;Note Status
+93 SET NSTS="A"
+94 IF DEDD]""
IF DTTM'<BRNG
IF DTTM'>ERNG
SET NSTS="C"
+95 SET NSTS=$SELECT(VIEN]"":" ",TYPE="C":" ",1:" ("_NSTS_") ")
+96 ;
+97 ;Determined signed/unsigned
+98 SET SIGN=$SELECT(SIGN]"":"S",1:"U")
IF SIGN="U"
QUIT
+99 ;
+100 ;Set up record
+101 ;
+102 ;Handle Wrapping
+103 DO WRAP^BJPNPRNT(.WRAP,$SELECT(NHYP:"",1:"-")_NSTS_NOTE_" ("_$SELECT('NVDT:$$FMTE^XLFDT(DTTM,"2D")_" ",1:"")_$SELECT(MDBY]"":"by ",1:"")_MDBY_")",72,2)
+104 ;
+105 ;Process each wrapped line
+106 SET WRAP=""
FOR LINE=1:1
SET WRAP=$ORDER(WRAP(WRAP))
IF WRAP=""
QUIT
Begin DoDot:2
+107 SET II=II+1
SET RESULT(II)=$EXTRACT(SPACE,1,5)_WRAP(WRAP)
End DoDot:2
End DoDot:1
+108 ;
+109 QUIT
